examples/iOS/program.scm

   1 ;;;============================================================================
   2
   3 ;;; File: "program.scm"
   4
   5 ;;; Copyright (c) 2011-2012 by Marc Feeley, All Rights Reserved.
   6
   7 ;; This program implements the "Gambit REPL" application for iOS
   8 ;; devices.  It is a simple development environment for Scheme.  The
   9 ;; user can interact with a REPL, and edit small scripts.
  10
  11 ;;;============================================================================
  12
  13 (##namespace ("gr#"))
  14
  15 (##include "~~lib/gambit#.scm")
  16 (##include "~~lib/_gambit#.scm")
  17
  18 (##namespace ("gr#" help)) ;; don't import help
  19
  20 (##include "wiki#.scm")
  21 (##include "html#.scm")
  22 (##include "url#.scm")
  23 (##include "json#.scm")
  24 (##include "repl-server#.scm")
  25 (##include "intf#.scm")
  26 (##include "script#.scm")
  27 (##include "repo#.scm")
  28 (##include "help#.scm")
  29
  30 (##namespace (""
  31               splash
  32               repl
  33               repl-eval
  34               repl-server
  35               wiki
  36               help
  37               edit
  38               reset-scripts
  39               remove-script
  40               store-script
  41               fetch-script
  42               view-script
  43              ))
  44
  45 (declare
  46  (standard-bindings)
  47  (extended-bindings)
  48  (block)
  49  (fixnum)
  50  ;;(not safe)
  51 )
  52
  53 ;;;----------------------------------------------------------------------------
  54
  55 ;; Add cond-expand features to identify Gambit-REPL.
  56
  57 (set! ##cond-expand-features
  58       (cons 'Gambit-REPL
  59             (cons 'Gambit-REPL-iOS
  60                   (cons 'Gambit-REPL-v4.0
  61                         ##cond-expand-features))))
  62
  63 ;;;----------------------------------------------------------------------------
  64
  65 ;; Common HTML header.
  66
  67 (define common-html-header #<<common-html-header-end
  68
  69 <html>
  70 <head>
  71
  72 <meta name="viewport" content="width=device-width, initial-scale=1.0, minimum-scale=0.25, maximum-scale=1.6">
  73
  74 <script>
  75
  76 function gestureStart() {
  77   var metas = document.getElementsByTagName('meta');
  78   for (var i=0; i<metas.length; i++) {
  79     if (metas[i].name === "viewport") {
  80       metas[i].content = "width=device-width, initial-scale=1.0, minimum-scale=0.25, maximum-scale=1.6";
  81     }
  82   }
  83 }
  84
  85 document.addEventListener("gesturestart", gestureStart, false);
  86
  87 </script>
  88
  89 <style TYPE="text/css">
  90 <!--
  91 body.splash {
  92     background-image: -webkit-gradient(linear, left top, left bottom, from(#fffb8b), to(#fffef0));
  93 }
  94 body.editor {
  95     background-color: #a0a0a0;
  96 }
  97 body.repo {
  98     background-image: -webkit-gradient(linear, left top, left bottom, from(#a0a0a0), to(#f0f0f0));
  99 }
 100 body.login {
 101     background-image: -webkit-gradient(linear, left top, left bottom, from(#a0a0a0), to(#f0f0f0));
 102 }
 103 body.help {
 104     background-image: -webkit-gradient(linear, left top, left bottom, from(#fffb8b), to(#fffef0));
 105 }
 106 .editorhead {
 107     float: right;
 108     height: 35px;
 109 }
 110 .repohead {
 111     height: 35px;
 112 }
 113 .button0 {
 114     display: inline-block;
 115     color: black;
 116     font: bold 14px Arial;
 117     text-align: center;
 118     padding: 2px 0px;
 119     width: 25px;
 120     border: 1px solid black;
 121     -webkit-border-radius: 5px;
 122     opacity: 1.0;
 123     margin: 5px;
 124     background-image: -webkit-gradient(linear, left top, left bottom, from(#fffef0), to(#fffb8b));
 125
 126 }
 127 .button1 {
 128     display: inline-block;
 129     color: white;
 130     font: bold 14px Arial;
 131     text-align: center;
 132     padding: 2px 0px;
 133     width: 35px;
 134     height: 20px;
 135     border: 1px solid black;
 136     -webkit-border-radius: 5px;
 137     opacity: 1.0;
 138     margin: 5px;
 139     background-image: -webkit-gradient(linear, left top, left bottom, from(#7f7fff), to(#2020b0));
 140 }
 141 .button2 {
 142     display: inline-block;
 143     color: white;
 144     font: bold 14px Arial;
 145     text-align: center;
 146     padding: 2px 0px;
 147     width: 50px;
 148     border: 1px solid black;
 149     -webkit-border-radius: 5px;
 150     opacity: 1.0;
 151     margin: 5px;
 152     background-image: -webkit-gradient(linear, left top, left bottom, from(#7f7fff), to(#2020b0));
 153 }
 154 .button3 {
 155     display: inline-block;
 156     color: white;
 157     font: bold 24px Arial;
 158     text-align: center;
 159     padding: 0px 0px;
 160     width: 35px;
 161     height: 28px;
 162     border: 1px solid black;
 163     -webkit-border-radius: 5px;
 164     opacity: 1.0;
 165     margin: 0px;
 166     background-image: -webkit-gradient(linear, left top, left bottom, from(#94a6be), to(#506070));
 167 }
 168 .bigbutton {
 169     display: inline-block;
 170     color: white;
 171     font: bold 14px Arial;
 172     text-align: center;
 173     padding: 7px 0px;
 174     width: 85px;
 175     border: 1px solid black;
 176     -webkit-border-radius: 5px;
 177     background-image: -webkit-gradient(linear, left top, left bottom, from(#688aba), to(#385a8a));
 178     opacity: 1.0;
 179     margin: 5px;
 180 }
 181 .widebutton {
 182     display: inline-block;
 183     color: black;
 184     font: bold 14px Arial;
 185     text-align: center;
 186     padding: 7px 0px;
 187     width: 140px;
 188     border: 1px solid black;
 189     -webkit-border-radius: 5px;
 190     opacity: 1.0;
 191     margin: 5px;
 192     background-image: -webkit-gradient(linear, left top, left bottom, from(#ffffff), to(#b0b0b0));
 193 }
 194 textarea.script {
 195     display: block;
 196     color: black;
 197     font: bold 12px Courier;
 198     width: 100%;
 199 }
 200 input.login {
 201     font: bold 18px Arial;
 202     width: 200px;
 203 }
 204 td.label {
 205     font: 18px Arial;
 206     text-align: right;
 207 }
 208 div.statuserror {
 209     color: red;
 210     font: bold 18px Arial;
 211 }
 212 div.statussuccess {
 213     color: green;
 214     font: bold 18px Arial;
 215 }
 216 div.statusbox {
 217     height: 70px;
 218 }
 219 div.spinner {
 220     position: relative;
 221     width: 54px;
 222     height: 54px;
 223     display: inline-block;
 224 }
 225 div.spinner div {
 226     width: 12%;
 227     height: 26%;
 228     background: #000;
 229     position: absolute;
 230     left: 44.5%;
 231     top: 37%;
 232     opacity: 0;
 233     -webkit-animation: fade 1s linear infinite;
 234     -webkit-border-radius: 50px;
 235     -webkit-box-shadow: 0 0 3px rgba(0,0,0,0.2);
 236 }
 237 div.spinner div.bar1 {-webkit-transform:rotate(0deg) translate(0, -142%); -webkit-animation-delay: 0s;}
 238 div.spinner div.bar2 {-webkit-transform:rotate(30deg) translate(0, -142%); -webkit-animation-delay: -0.9167s;}
 239 div.spinner div.bar3 {-webkit-transform:rotate(60deg) translate(0, -142%); -webkit-animation-delay: -0.833s;}
 240 div.spinner div.bar4 {-webkit-transform:rotate(90deg) translate(0, -142%); -webkit-animation-delay: -0.75s;}
 241 div.spinner div.bar5 {-webkit-transform:rotate(120deg) translate(0, -142%); -webkit-animation-delay: -0.667s;}
 242 div.spinner div.bar6 {-webkit-transform:rotate(150deg) translate(0, -142%); -webkit-animation-delay: -0.5833s;}
 243 div.spinner div.bar7 {-webkit-transform:rotate(180deg) translate(0, -142%); -webkit-animation-delay: -0.5s;}
 244 div.spinner div.bar8 {-webkit-transform:rotate(210deg) translate(0, -142%); -webkit-animation-delay: -0.41667s;}
 245 div.spinner div.bar9 {-webkit-transform:rotate(240deg) translate(0, -142%); -webkit-animation-delay: -0.333s;}
 246 div.spinner div.bar10 {-webkit-transform:rotate(270deg) translate(0, -142%); -webkit-animation-delay: -0.25s;}
 247 div.spinner div.bar11 {-webkit-transform:rotate(300deg) translate(0, -142%); -webkit-animation-delay: -0.1667s;}
 248 div.spinner div.bar12 {-webkit-transform:rotate(330deg) translate(0, -142%); -webkit-animation-delay: -0.0833s;}
 249 @-webkit-keyframes fade {
 250     from {opacity: 1;}
 251     to {opacity: 0.25;}
 252 }
 253 td.repoget {
 254     width: 38px;
 255 }
 256 td.repoentry {
 257     font: 14px Arial;
 258     word-break: break-all;
 259 }
 260 -->
 261 </style>
 262 </head>
 263
 264 common-html-header-end
 265 )
 266
 267 ;;;----------------------------------------------------------------------------
 268
 269 ;; Splash page.
 270
 271 (define splash-page-content-part1 #<<splash-page-content-part1-end
 272
 273 <body class="splash">
 274
 275 <p>
 276 Welcome to <strong>
 277 splash-page-content-part1-end
 278 )
 279
 280 (define splash-page-content-part2 #<<splash-page-content-part2-end
 281 </strong>, a Scheme development environment based on the <a href="event:wiki">Gambit Scheme programming system</a>.
 282 </p>
 283
 284 <ul>
 285 <li/> learn the Scheme language,
 286 <li/> debug Scheme code on the go,
 287 <li/> number crunch exactly!
 288 </ul>
 289
 290 <p>
 291 In the REPL view, enter your command after the <strong><code>&gt;</code></strong> prompt, then tap <strong>return</strong> to display the result. Here is a sample interaction:<br/>
 292 <strong>
 293 <code>
 294 <br/>
 295 &gt; (+ 1 (/ (* 2 2) (sqrt 9)))<br/>
 296 7/3<br/>
 297 &gt; (expt 2 100)<br/>
 298 1267650600228229401496703205376<br/>
 299 &gt; (reverse (string-&gt;list "hello"))<br/>
 300 (#\o #\l #\l #\e #\h)<br/>
 301 &gt; \for (int i=1;i&lt;=3;i++) pp(i*i);<br/>
 302 1<br/>
 303 4<br/>
 304 9<br/>
 305 </code>
 306 </strong>
 307 </p>
 308
 309 </body>
 310 </html>
 311
 312 splash-page-content-part2-end
 313 )
 314
 315 (define (set-splash-view)
 316   (set-view-content
 317    0
 318    (list common-html-header
 319          splash-page-content-part1
 320          CFBundleDisplayName
 321          splash-page-content-part2)
 322    #f
 323    #t))
 324
 325 (define (splash)
 326   (set-navigation -1)
 327   (set-event-handler
 328    (lambda (old-event-handler)
 329      generic-event-handler))
 330   (show-view 0))
 331
 332
 333 ;;;----------------------------------------------------------------------------
 334
 335 ;; Help page.
 336
 337 (define current-help-document #f)
 338
 339 (define (help #!optional (subject (macro-absent-obj)))
 340   (if (eq? subject (macro-absent-obj))
 341       (show-help-document (or current-help-document main-help-document) #f)
 342       (##help subject)))
 343
 344 (define (show-help-document docu anchor)
 345   (let ((load-docu? (not (equal? docu current-help-document))))
 346
 347     (define (goto-anchor)
 348       (if anchor
 349           (eval-js-in-webView
 350            2
 351            (string-append "window.location='#" anchor "'"))))
 352
 353     (set-event-handler
 354      (lambda (old-event-handler)
 355        (lambda (event)
 356          (cond ((and load-docu? (equal? event "event:loaded"))
 357                 (if (not (equal? docu main-help-document))
 358                     (show-cancelButton))
 359                 (goto-anchor))
 360
 361                ((equal? event "event:r5rs")
 362                 (show-help-document r5rs-help-document #f))
 363
 364                ((equal? event "event:gambit-c")
 365                 (show-help-document gambit-c-help-document #f))
 366
 367                ((equal? event "cancel")
 368                 (hide-cancelButton)
 369                 (show-help-document main-help-document #f))
 370
 371                ((wiki-event-handler event))
 372
 373                ((handle-create-account-event event))
 374
 375                (else
 376                 (handle-navigation-event
 377                  event
 378                  (lambda ()
 379                    (hide-cancelButton))))))))
 380
 381     (if load-docu?
 382         (begin
 383           (set! current-help-document docu)
 384           (set-webView-content-from-file 2 docu (path-directory docu) #t))
 385         (goto-anchor))
 386
 387     (set-navigation 2)
 388     (show-view 2)
 389
 390     (if (not (equal? docu main-help-document))
 391         (show-cancelButton))))
 392
 393
 394 ;;;----------------------------------------------------------------------------
 395
 396 ;; REPL page.
 397
 398 (define (repl)
 399   (set-navigation 0)
 400   (set-event-handler
 401    (lambda (old-event-handler)
 402      generic-event-handler))
 403   (show-textView 0))
 404
 405 (define (repl-eval str)
 406   (if (string? str)
 407       (begin
 408         (add-output-to-textView 0 str)
 409         (send-input str)
 410         (repl))))
 411
 412 (define (repl-server password)
 413   (repl-server-start password))
 414
 415 (set! ##primordial-exception-handler-hook
 416       (lambda (exc other-handler)
 417         (repl) ;; switch to REPL view on errors
 418         (##repl-exception-handler-hook exc other-handler)))
 419
 420
 421 ;;;----------------------------------------------------------------------------
 422
 423 ;; Script editor.
 424
 425 (define edit-page-content-part1 #<<edit-page-content-part1-end
 426
 427 <script language="JavaScript">
 428
 429 edit-page-content-part1-end
 430 )
 431
 432 (define edit-page-content-part2 #<<edit-page-content-part2-end
 433
 434 function send_event(e)
 435 { window.location = "event:" + e; }
 436
 437 function send_event_with_scripts(e,index)
 438 { window.location = event_with_scripts(e,index); }
 439
 440 function event_with_scripts(e,index)
 441 {
 442   var strings = ["event:"+e,index];
 443   for (var i = 0; i<nb_scripts; i++)
 444   {
 445     strings.push(encodeURIComponent(document.getElementById("script"+i).value));
 446   }
 447   strings.push("");
 448   return strings.join(":");
 449 }
 450
 451 function click_new()
 452 { send_event_with_scripts("new",0); }
 453
 454 function click_run(index)
 455 { send_event_with_scripts("run",index); }
 456
 457 function click_save(index)
 458 { var script = document.getElementById("script"+index).value;
 459   var lines = script.split(/\n/);
 460   var line1 = lines[0];
 461   var name = line1.replace(/^;;; /,"");
 462   var event = (/^[^\n]*\s*$/.exec(script)) ? "remove" : "save";
 463   if (name.length < line1.length && /^[A-Za-z][-\.A-Za-z0-9]*\.scm$/.exec(name))
 464   {
 465     if (confirm((event==="remove")?('Are you sure you want to remove\n\n'+name+'\n\nfrom the Documents folder?'):('Are you sure you want to save\n\n'+name+'\n\nto the Documents folder?')))
 466       send_event_with_scripts(event,index);
 467   }
 468
 469 edit-page-content-part2-end
 470 )
 471
 472 (define edit-page-content-part3 #<<edit-page-content-part3-end
 473   else if (name.length < line1.length && /^[A-Z][-\. A-Za-z0-9]*:[-\. A-Za-z0-9:]*\.scm$/.exec(name))
 474   {
 475     if (confirm((event==="remove")?('Are you sure you want to remove\n\n'+name+'\n\nfrom the Gambit wiki?'):('Are you sure you want to save\n\n'+name+'\n\nto the Gambit wiki? It will replace the current script by that name if it exists. Note that previous versions of the script will still be available in the Gambit wiki page history.')))
 476       send_event_with_scripts(event,index);
 477   }
 478
 479 edit-page-content-part3-end
 480 )
 481
 482 (define edit-page-content-part4 #<<edit-page-content-part4-end
 483   else
 484   {
 485     alert("The script cannot be saved because it is improperly named.  The first line must be the name of the script preceded by three semicolons and a space, for example:\n\n;;; test.scm\n\nMoreover, the name must start with a letter, and end in '.scm', and contain only letters, digits, '.', and '-'.");
 486   }
 487 }
 488
 489 function click_delete(index)
 490 { if (confirm('Are you sure you want to delete this script from the Edit view?'))
 491     send_event_with_scripts("delete",index);
 492 }
 493
 494 function lose_focus()
 495 { return event_with_scripts("exit",0); }
 496
 497 </script>
 498
 499 <body class="editor">
 500
 501 <span class="editorhead">
 502 <div class="button3" onClick="click_new();">+</div>
 503 </span>
 504
 505 edit-page-content-part4-end
 506 )
 507
 508 (define edit-page-content-part5 #<<edit-page-content-part5-end
 509
 510 </body>
 511 </html>
 512
 513 edit-page-content-part5-end
 514 )
 515
 516 (define edit-page-script-rows-iPad    20)
 517 (define edit-page-script-rows-default 10)
 518
 519 (define edit-page-script-rows
 520   (case (device-model)
 521     ((iPad) edit-page-script-rows-iPad)
 522     (else   edit-page-script-rows-default)))
 523
 524 (define (html-for-local-scripts scripts)
 525
 526   (define (html script name index)
 527     (list "<br/>\n"
 528           "<textarea class=\"script\" id=\"script" index "\" rows="
 529           edit-page-script-rows
 530           ">"
 531           (html-escape script)
 532           "</textarea>\n"
 533           "<center>\n"
 534           "<div class=\"button2\" onClick=\"click_run(" index ");\">Run</div>\n"
 535           "&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;"
 536           "<div class=\"button2\" onClick=\"click_save(" index ");\">Save</div>\n"
 537           "&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;"
 538           "<div class=\"button2\" onClick=\"click_delete(" index ");\">Delete</div>\n"
 539           "</center>\n"))
 540
 541   (let loop ((scripts scripts) (i 0) (accum '()))
 542     (if (pair? scripts)
 543         (let* ((x (car scripts))
 544                (name (car x))
 545                (script (cdr x)))
 546           (loop (cdr scripts)
 547                 (+ i 1)
 548                 (cons (html (add-script-name-if-needed name script) name i)
 549                       accum)))
 550         (reverse accum))))
 551
 552 (define (add-script-name-if-needed name script)
 553   (if (not (wiki-script-name-type name))
 554       script
 555       (let ((name-in-script (extract-script-name script)))
 556         (if (equal? name name-in-script)
 557             script
 558             (string-append
 559              script-name-prefix
 560              name
 561              "\n\n"
 562              script)))))
 563
 564 (define (set-edit-view)
 565   (set-view-content
 566    3
 567    (let ((scripts (get-script-db)))
 568      (list common-html-header
 569            edit-page-content-part1
 570            "var nb_scripts = " (length scripts) ";\n"
 571            edit-page-content-part2
 572            (if repo-enabled?
 573                edit-page-content-part3
 574                "")
 575            edit-page-content-part4
 576            (html-for-local-scripts scripts)
 577            edit-page-content-part5))
 578    #f
 579    #t))
 580
 581 (define (edit)
 582   (set-navigation 3)
 583   (set-event-handler
 584    (lambda (old-event-handler)
 585      (lambda (event)
 586        (handle-edit-event
 587         event
 588         (lambda ()
 589           (handle-navigation-event
 590            event
 591            (lambda ()
 592              (let ((new-event (eval-js-in-webView 3 "lose_focus()")))
 593                (and (string? new-event)
 594                     (handle-edit-event
 595                      new-event
 596                      (lambda ()
 597                        #f)))))))))))
 598   (show-view 3))
 599
 600 (define (get-index-and-update-script-db rest)
 601   (let ((x (get-event-parameters rest)))
 602     (if (pair? x)
 603         (let ((index (string->number (car x))))
 604           (let loop ((lst (cdr x)) (rev-scripts '()))
 605             (if (pair? lst)
 606                 (let ((script (car lst)))
 607                   (loop (cdr lst)
 608                         (cons (cons (extract-script-name script) script)
 609                               rev-scripts)))
 610                 (let ((new-script-db (reverse rev-scripts)))
 611
 612                   (set-pref "run-main-script" "yes")
 613
 614                   (set! script-db new-script-db)
 615                   (save-script-db)
 616                   index))))
 617         #f)))
 618
 619 (define (handle-edit-event event otherwise)
 620   (cond ((has-prefix? event "event:new:") =>
 621          (lambda (rest)
 622            (get-index-and-update-script-db rest)
 623            (new-script)
 624            (set-edit-view)))
 625
 626         ((has-prefix? event "event:run:") =>
 627          (lambda (rest)
 628            (run-script-event
 629             (get-index-and-update-script-db rest))))
 630
 631         ((has-prefix? event "event:save:") =>
 632          (lambda (rest)
 633            (save-script-event
 634             (get-index-and-update-script-db rest))))
 635
 636         ((has-prefix? event "event:remove:") =>
 637          (lambda (rest)
 638            (remove-script-event
 639             (get-index-and-update-script-db rest))))
 640
 641         ((has-prefix? event "event:delete:") =>
 642          (lambda (rest)
 643            (delete-script-event
 644             (get-index-and-update-script-db rest))
 645            (set-edit-view)))
 646
 647         ((has-prefix? event "event:exit:") =>
 648          (lambda (rest)
 649            (get-index-and-update-script-db rest)))
 650
 651         (else
 652          (otherwise))))
 653
 654 (define (handle-navigation-event event lose-focus-handler)
 655   (let ((nav (has-prefix? event "NAV")))
 656     (if nav
 657         (let ((n (string->number nav)))
 658           (lose-focus-handler)
 659           (case n
 660             ((1)
 661              (wiki))
 662
 663             ((2)
 664              (help))
 665
 666             ((3)
 667              (edit))
 668
 669             (else
 670              (repl)))))))
 671
 672 (define (wiki-event-handler event)
 673   (or (and (equal? event "event:wiki")
 674            (begin
 675              (visit-wiki)
 676              #t))
 677       (and (equal? event "event:wiki-Gambit-REPL")
 678            (begin
 679              (visit-wiki-Gambit-REPL)
 680              #t))))
 681
 682 (define (visit-wiki)
 683   (open-URL
 684    (string-append
 685     "http://"
 686     wiki-server-address
 687     wiki-root
 688     "/index.php")))
 689
 690 (define (visit-wiki-Gambit-REPL)
 691   (open-URL
 692    (string-append
 693     "http://"
 694     wiki-server-address
 695     wiki-root
 696     "/index.php/Gambit_REPL")))
 697
 698 (define latest-pasteboard #f)
 699
 700 (define (handle-app-become-active-event event)
 701   (and (equal? event "app-become-active")
 702        (let* ((script (get-pasteboard))
 703               (name (and script
 704                          (not (equal? script latest-pasteboard))
 705                          (extract-script-name script))))
 706          (set! latest-pasteboard script)
 707          (if name
 708              (set-event-handler
 709               (lambda (old-event-handler)
 710                 (popup-alert (string-append CFBundleName ".app")
 711                              (string-append
 712                               "Create the script\n\n"
 713                               name
 714                               "\n\nin the Edit view from the content of the pasteboard?")
 715                              "No"
 716                              "Yes")
 717                 (lambda (event)
 718
 719                   (define (done accept?)
 720                     (set-event-handler
 721                      (lambda (new-event-handler)
 722                        old-event-handler))
 723                     (if accept?
 724                         (begin
 725                           (add-script name script)
 726                           (set-edit-view)
 727                           (edit))))
 728
 729                   (cond ((equal? event "popup-alert-cancel")
 730                          (done #f))
 731                         ((equal? event "popup-alert-accept")
 732                          (done #t)))))))
 733          #t)))
 734
 735 (define (handle-create-account-event event)
 736   (and (equal? event "event:create-account")
 737        (begin
 738          (open-URL
 739           (string-append
 740            "http://"
 741            wiki-server-address
 742            wiki-root
 743            "/index.php/Special:RequestAccount"))
 744          #t)))
 745
 746 (define (generic-event-handler event)
 747   (or (wiki-event-handler event)
 748       (handle-app-become-active-event event)
 749       (handle-create-account-event event)
 750       (handle-navigation-event event (lambda () #f))))
 751
 752 (define run-script-event #f)
 753 (set! run-script-event
 754       (lambda (index)
 755         (let ((name-script (get-script-at-index index)))
 756           (and name-script
 757                (let ((name (car name-script))
 758                      (script (cdr name-script)))
 759                  (run-script name script))))))
 760
 761 (define save-script-event #f)
 762 (set! save-script-event
 763       (lambda (index)
 764         (let ((name-script (get-script-at-index index)))
 765           (and name-script
 766                (let ((name (car name-script))
 767                      (script (cdr name-script)))
 768                  (store-script name script edit))))))
 769
 770 (define remove-script-event #f)
 771 (set! remove-script-event
 772       (lambda (index)
 773         (let ((name-script (get-script-at-index index)))
 774           (and name-script
 775                (let ((name (car name-script))
 776                      (script (cdr name-script)))
 777                  (remove-script name edit))))))
 778
 779 (define (reset-scripts)
 780   (script#reset-scripts)
 781   (set-edit-view))
 782
 783 (define (remove-script name #!optional (back repl))
 784   (case (wiki-script-name-type name)
 785     ((wiki)
 786      (repo-transaction
 787       (lambda ()
 788         (wiki-script-name-verify name)
 789         (wiki-script-remove name)
 790         (back))
 791       ""
 792       (list "<h3>Removing script</h3>" (html-escape name) "<br/>")
 793       "The script has been removed from the Gambit wiki"
 794       "Could not remove script!"
 795       back))
 796
 797     ((file)
 798      (with-exception-catcher
 799       (lambda (e)
 800         (display-exception e (repl-output-port))
 801         (repl))
 802       (lambda ()
 803         (delete-file (##path-expand name "~"))))
 804      (back))))
 805
 806 (define (store-script name script #!optional (back repl))
 807   (case (wiki-script-name-type name)
 808     ((wiki)
 809      (repo-transaction
 810       (lambda ()
 811         (wiki-script-name-verify name)
 812         (wiki-script-store name script)
 813         (back))
 814       ""
 815       (list "<h3>Storing script</h3>" (html-escape name) "<br/>")
 816       "The script has been stored on the Gambit wiki"
 817       "Could not store script!"
 818       back))
 819
 820     ((file)
 821      (with-exception-catcher
 822       (lambda (e)
 823         (display-exception e (repl-output-port))
 824         (repl))
 825       (lambda ()
 826         (call-with-output-file
 827             (##path-expand name "~")
 828           (lambda (port)
 829             (display script port)))))
 830      (back))))
 831
 832 (define (fetch-script name #!optional (back repl))
 833   (case (wiki-script-name-type name)
 834     ((wiki)
 835      (repo-transaction
 836       (lambda ()
 837         (wiki-script-name-verify name)
 838         (let ((script (wiki-script-fetch name)))
 839           (add-script name script)
 840           (set-edit-view)
 841           (back)))
 842       ""
 843       (list "<h3>Fetching script</h3>" (html-escape name) "<br/>")
 844       "The script has been fetched from the Gambit wiki"
 845       "Could not fetch script!"
 846       back))
 847
 848     ((file)
 849      (with-exception-catcher
 850       (lambda (e)
 851         (display-exception e (repl-output-port))
 852         (repl))
 853       (lambda ()
 854         (let ((script
 855                (call-with-input-file
 856                    (##path-expand name "~")
 857                  (lambda (port)
 858                    (read-line port #f)))))
 859           (add-script name script)
 860           (set-edit-view)
 861           (back))))
 862      (back))))
 863
 864 (define (delete-script-event index)
 865   (let loop ((scripts (get-script-db)) (i 0) (accum '()))
 866     (if (pair? scripts)
 867         (if (= i index)
 868             (set! script-db (append (reverse accum)
 869                                     (cdr scripts)))
 870             (loop (cdr scripts) (+ i 1) (cons (car scripts) accum)))))
 871   (save-script-db))
 872
 873 (define script-name-prefix ";;; ") ;; must be consistent with the definition of the click_save JavaScript function
 874
 875 (define (extract-script-name script)
 876   (let* ((line1 (first-line script))
 877          (name (has-prefix? line1 script-name-prefix)))
 878     (and (wiki-script-name-type name)
 879          name)))
 880
 881 (define (first-line str)
 882   (let loop ((i 0))
 883     (if (< i (string-length str))
 884         (if (char=? (string-ref str i) #\newline)
 885             (substring str 0 i)
 886             (loop (+ i 1)))
 887         str)))
 888
 889
 890 ;;;----------------------------------------------------------------------------
 891
 892 ;; Repository browser.
 893
 894 (define repo-page-content-part1 #<<repo-page-content-part1-end
 895
 896 <body class="repo">
 897
 898 repo-page-content-part1-end
 899 )
 900
 901 (define repo-page-content-part2 #<<repo-page-content-part2-end
 902
 903 <div class="repohead">
 904 <div class="button1" onClick="window.location='event:back';">&#9664;</div>
 905 </div>
 906
 907 repo-page-content-part2-end
 908 )
 909
 910 (define repo-page-content-part3 #<<repo-page-content-part3-end
 911
 912 <div class="repohead">
 913 &nbsp;
 914 </div>
 915
 916 repo-page-content-part3-end
 917 )
 918
 919 (define repo-page-content-part4 #<<repo-page-content-part4-end
 920
 921 <form>
 922 <table>
 923
 924
 925 repo-page-content-part4-end
 926 )
 927
 928 (define repo-page-content-part5 #<<repo-page-content-part5-end
 929
 930 </table>
 931 </form>
 932 </body>
 933 </html>
 934
 935 repo-page-content-part5-end
 936 )
 937
 938 (define (html-for-script-tree tree)
 939
 940   (define (html branch)
 941     (let ((name (car branch))
 942           (subtree (cdr branch)))
 943       (list "<tr>"
 944             (if (pair? subtree)
 945                 (list "<td class=\"repoget\"></td>\n"
 946                       "<td><div class=\"button1\" onClick=\"window.location='event:view:"
 947                       (url-encode name)
 948                       "';\">&#9654;</div></td>\n")
 949                 (list "<td class=\"repoget\"><div class=\"button0\" onClick=\"window.location='event:get:"
 950                       (url-encode name)
 951                       "';\">Get</div></td>\n"
 952                       "<td><div class=\"button1\" onClick=\"window.location='event:view:"
 953                       (url-encode name)
 954                       "';\">View</div></td>\n"))
 955             "<td class=\"repoentry\">"
 956             (html-escape name)
 957             "</td>\n"
 958             "</tr>\n")))
 959
 960   (let loop ((tree tree) (accum '()))
 961     (if (pair? tree)
 962         (let ((branch (car tree)))
 963           (loop (cdr tree) (cons (html branch) accum)))
 964         (reverse accum))))
 965
 966 (define repo-enabled? #f)
 967
 968 (define (repo-enable!)
 969   (if (not repo-enabled?)
 970       (begin
 971         (set! repo-enabled? #t)
 972         (segm-ctrl-set-title 1 "Repo"))))
 973
 974 (define (repo)
 975   (repo-enable!)
 976   (wiki))
 977
 978 (define (wiki)
 979   (if (not repo-enabled?)
 980       (begin
 981         (visit-wiki-Gambit-REPL)
 982         (repl))
 983       (repo-transaction
 984        (lambda ()
 985          (let ((scripts (wiki-script-list)))
 986            (repo-browse #f (script-list->tree scripts))))
 987        repo-page-content-part3
 988        (list "<h3>Accessing Gambit wiki</h3><br/>")
 989        #f
 990        "Could not get list of scripts!"
 991        repl)))
 992
 993 (define (script-list->tree scripts)
 994
 995   (define (cvt scripts prefix)
 996     (if (not (pair? scripts))
 997         '()
 998         (let ((script1 (car scripts)))
 999           (let loop1 ((i 0))
1000             (if (< i (string-length script1))
1001                 (if (not (char=? (string-ref script1 i) #\:))
1002                     (loop1 (+ i 1))
1003                     (let ((p (substring script1 0 (+ i 1))))
1004                       (let loop2 ((lst scripts) (rev-subtrees '()))
1005
1006                         (define (end)
1007                           (let ((new-prefix (string-append prefix p)))
1008                             (cons (cons new-prefix
1009                                         (cvt (reverse rev-subtrees) new-prefix))
1010                                   (cvt lst prefix))))
1011
1012                         (if (pair? lst)
1013                             (let ((s (car lst)))
1014                               (if (and (<= i (string-length s))
1015                                        (string=? (substring s 0 (+ i 1)) p))
1016                                   (loop2 (cdr lst)
1017                                          (cons (substring s (+ i 1) (string-length s))
1018                                                rev-subtrees))
1019                                   (end)))
1020                             (end)))))
1021                 (cons (cons (string-append prefix script1) '())
1022                       (cvt (cdr scripts) prefix)))))))
1023
1024   (cvt scripts ""))
1025
1026 (define (repo-browse back tree)
1027   (set-navigation 1)
1028   (set-event-handler
1029    (lambda (old-event-handler)
1030      (lambda (event)
1031        (cond ((has-prefix? event "event:view:") =>
1032               (lambda (rest)
1033                 (let* ((params (get-event-parameters rest))
1034                        (name (car params))
1035                        (branch (assoc name tree)))
1036                   (if branch
1037                       (let ((subtree (cdr branch)))
1038                         (if (pair? subtree)
1039                             (repo-browse (lambda () (repo-browse back tree))
1040                                          subtree)
1041                             (view-script name)))))))
1042
1043              ((has-prefix? event "event:get:") =>
1044               (lambda (rest)
1045                 (let* ((params (get-event-parameters rest))
1046                        (name (car params)))
1047                   (get-repo-script-event name edit))))
1048
1049              ((equal? event "event:back")
1050               (back))
1051
1052              (else
1053               (generic-event-handler event))))))
1054   (set-view-content
1055    1
1056    (list common-html-header
1057          repo-page-content-part1
1058          (if back
1059              repo-page-content-part2
1060              repo-page-content-part3)
1061          repo-page-content-part4
1062          (html-for-script-tree tree)
1063          repo-page-content-part5)
1064    #f
1065    #t)
1066   (show-view 1))
1067
1068 (define (view-script name)
1069   (open-URL
1070    (string-append
1071     "http://"
1072     wiki-server-address
1073     wiki-root
1074     "/index.php/"
1075     (url-encode
1076      (string-append wiki-script-prefix name)))))
1077
1078 (define get-repo-script-event #f)
1079 (set! get-repo-script-event fetch-script)
1080
1081
1082 ;;;----------------------------------------------------------------------------
1083
1084 ;; Repository transaction page.
1085
1086 (define repo-transaction-page-content-part1 #<<repo-transaction-page-content-part1-end
1087
1088 <center>
1089
1090 repo-transaction-page-content-part1-end
1091 )
1092
1093 (define repo-transaction-page-content-part2 #<<repo-transaction-page-content-part2-end
1094
1095 </center>
1096
1097 <br/>
1098
1099 <center><div class="statusbox">
1100
1101 repo-transaction-page-content-part2-end
1102 )
1103
1104 (define repo-transaction-page-content-part3 #<<repo-transaction-page-content-part3-end
1105 </div></center>
1106
1107 </body>
1108 </html>
1109
1110 repo-transaction-page-content-part3-end
1111 )
1112
1113 (define (make-repo-transaction-page header msg status)
1114   (list common-html-header
1115         repo-page-content-part1
1116         header
1117         repo-transaction-page-content-part1
1118         msg
1119         repo-transaction-page-content-part2
1120         status
1121         repo-transaction-page-content-part3))
1122
1123 (define (repo-transaction thunk header msg success-msg failure-msg back)
1124
1125   (define (exec)
1126
1127     (let ((content (make-repo-transaction-page header msg spinner-html)))
1128       (set-navigation 1)
1129       (set-view-content 1 content #f #t)
1130       (show-view 1))
1131
1132     (guard-repo-transaction
1133      (lambda ()
1134
1135        (thunk)
1136
1137        (if success-msg
1138            (begin
1139
1140              (set-view-content
1141               1
1142               (make-repo-transaction-page
1143                header
1144                msg
1145                (list "<div class=\"statussuccess\">"
1146                      success-msg
1147                      "</div>"))
1148               #f
1149               #t)
1150
1151              (thread-sleep! 2) ;; display success message for 2 seconds
1152
1153              (back))))
1154      header
1155      msg
1156      failure-msg
1157      back))
1158
1159   (auto-login
1160    exec
1161    back))
1162
1163 (define (guard-repo-transaction thunk header msg failure-msg back)
1164   (with-exception-catcher
1165    (lambda (e)
1166
1167      (set-view-content
1168       1
1169       (make-repo-transaction-page
1170        header
1171        msg
1172        (list "<div class=\"statuserror\">"
1173              failure-msg
1174              "<br/><br/>"
1175              (exception->error-msg e)
1176              "</div>"))
1177       #f
1178       #t)
1179
1180      (thread-sleep! 4) ;; display error message for 4 seconds
1181
1182      (back))
1183    thunk))
1184
1185 (define spinner-html
1186   "<div class=\"spinner\"><div class=\"bar1\"></div><div class=\"bar2\"></div><div class=\"bar3\"></div><div class=\"bar4\"></div><div class=\"bar5\"></div><div class=\"bar6\"></div><div class=\"bar7\"></div><div class=\"bar8\"></div><div class=\"bar9\"></div><div class=\"bar10\"></div><div class=\"bar11\"></div><div class=\"bar12\"></div></div>")
1187
1188 (define (exception->error-msg e)
1189   (cond ((equal? e "NotExists")
1190          "Username does not exist")
1191         ((or (equal? e "NoName")
1192              (equal? e "Illegal"))
1193          "Illegal username")
1194         ((or (equal? e "EmptyPass")
1195              (equal? e "WrongPass")
1196              (equal? e "WrongPluginPass"))
1197          "Wrong password")
1198         ((or (equal? e "Blocked")
1199              (equal? e "CreateBlocked"))
1200          "This user is blocked")
1201         ((equal? e "Throttled")
1202          "Too many logins... try again later")
1203         ((equal? e "failed to connect")
1204          "Could not connect to Gambit wiki")
1205         ((equal? e "script not found")
1206          "Script not found")
1207         ((equal? e "malformed script")
1208          "Script is not properly formatted")
1209         ((equal? e "you must first login to the Gambit wiki")
1210          "Not logged in to the Gambit wiki")
1211         ((or (equal? e "script name must be a string")
1212              (equal? e "script name must end with \".scm\"")
1213              (equal? e "script name must start with an upper case letter")
1214              (equal? e "script name must contain at least one colon")
1215              (equal? e "illegal character in script name"))
1216          "Invalid script name")
1217         ((equal? e "unknown")
1218          "Unknown error")
1219         (else
1220          (with-output-to-string "" (lambda () (display-exception e))))))
1221
1222
1223 ;;;----------------------------------------------------------------------------
1224
1225 ;; Repository login.
1226
1227 (define login-page-content-part1 #<<login-page-content-part1-end
1228
1229 <body class="login">
1230
1231 <center>
1232 <h1>Log in to Gambit wiki</h1>
1233
1234 <form onSubmit="window.location='event:login:'+encodeURIComponent(document.getElementById('username').value)+':'+encodeURIComponent(document.getElementById('password').value)+':'+encodeURIComponent(document.getElementById('rememberpass').value)+':'; return false;">
1235
1236 <table>
1237 <tr>
1238   <td class="label">Username:</td>
1239   <td class="login"><input class="login" id="username" type="text" value="
1240 login-page-content-part1-end
1241 )
1242
1243 (define login-page-content-part2 #<<login-page-content-part2-end
1244 " /></td>
1245 </tr><tr>
1246   <td class="label">Password:</td>
1247   <td class="login"><input class="login" id="password" type="password" value="
1248 login-page-content-part2-end
1249 )
1250
1251 (define login-page-content-part3 #<<login-page-content-part3-end
1252 " /></td>
1253 <tr>
1254   <td></td>
1255   <td><input type="checkbox" id="rememberpass"
1256 login-page-content-part3-end
1257 )
1258
1259 (define login-page-content-part4 #<<login-page-content-part4-end
1260 />Remember my password</td>
1261 </tr>
1262 </table>
1263
1264 <br/>
1265
1266 <input type="submit" class="bigbutton" value="Log in" />
1267 &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
1268 <input type="button" class="bigbutton" value="Cancel" onClick="window.location='event:cancel';" />
1269
1270 </form>
1271
1272 </center>
1273
1274 <center><div class="statusbox">
1275
1276 login-page-content-part4-end
1277 )
1278
1279 (define login-page-content-part5 #<<login-page-content-part5-end
1280 </div></center>
1281
1282 <center>
1283 If you don't have an account, you should<br/>
1284 <div class="widebutton" onClick="window.location='event:create-account';">Create an account</div><br/>
1285 It's free!
1286 </center>
1287
1288 </body>
1289 </html>
1290
1291 login-page-content-part5-end
1292 )
1293
1294 (define (make-login-page username password remember-pass? msg)
1295   (list common-html-header
1296         login-page-content-part1
1297         (html-escape username)
1298         login-page-content-part2
1299         (html-escape password)
1300         login-page-content-part3
1301         (if remember-pass? "checked " "")
1302         login-page-content-part4
1303         msg
1304         login-page-content-part5))
1305
1306 (define (make-initial-login-page)
1307   (let ((info (get-login-info)))
1308     (make-login-page
1309      (car info)
1310      (cadr info)
1311      (caddr info)
1312      "")))
1313
1314 (define (auto-login success fail)
1315   (if (wiki-logged-in?)
1316       (success)
1317       (login success fail)))
1318
1319 (define (login #!optional (success repl) (fail repl))
1320   (login-with-page (make-initial-login-page) success fail))
1321
1322 (define (login-with-page page success fail)
1323   (set-navigation 1)
1324   (set-event-handler
1325    (lambda (old-event-handler)
1326      (lambda (event)
1327        (cond ((has-prefix? event "event:login:") =>
1328               (lambda (rest)
1329                 (let* ((params (get-event-parameters rest))
1330                        (username (car params))
1331                        (password (cadr params))
1332                        (remember-pass? (equal? (caddr params) "on")))
1333                   (attempt-login success
1334                                  fail
1335                                  username
1336                                  password
1337                                  remember-pass?))))
1338
1339              ((equal? event "event:cancel")
1340               (fail))
1341
1342              (else
1343               (generic-event-handler event))))))
1344   (set-view-content 1 page #f #t)
1345   (show-view 1))
1346
1347 (define (attempt-login success fail username password remember-pass?)
1348
1349   (set-login-info username password remember-pass?)
1350
1351   (save-login-info)
1352
1353   (set-view-content
1354    1
1355    (make-login-page
1356     username
1357     password
1358     remember-pass?
1359     spinner-html)
1360    #f
1361    #t)
1362
1363   ((with-exception-catcher
1364
1365     (lambda (e)
1366       (let ((msg
1367              (list "<div class=\"statuserror\">"
1368                    (exception->error-msg e)
1369                    "</div>")))
1370         (lambda ()
1371           (login-with-page
1372            (make-login-page
1373             username
1374             password
1375             remember-pass?
1376             msg)
1377            success
1378            fail))))
1379
1380     (lambda ()
1381
1382       (wiki-logout)
1383       (wiki-login username password #t)
1384
1385       (set-view-content
1386        1
1387        (make-login-page
1388         username
1389         password
1390         remember-pass?
1391         "<div class=\"statussuccess\">You are now logged in!</div>")
1392        #f
1393        #t)
1394
1395       (thread-sleep! 2) ;; display success message for 2 seconds
1396
1397       success))))
1398
1399
1400 ;;;----------------------------------------------------------------------------
1401
1402 ;; Opening URLs.
1403
1404 (##namespace ("" open-URL))
1405
1406 (define (open-URL str)
1407   (if (string? str)
1408       (intf#open-URL str)))
1409
1410
1411 ;;;----------------------------------------------------------------------------
1412
1413 ;; Key handler.
1414
1415 (set! handle-key
1416   (lambda (str)
1417     (if (char=? #\F (string-ref str 0))
1418         (let ((script (get-script-by-name str)))
1419           (if script
1420               (run-script str script)
1421               (let ((n (string->number (substring str 1 (string-length str)))))
1422                 (cond ((eqv? n 12)
1423                        (##thread-interrupt! (macro-primordial-thread)))
1424                       ((and n (<= n 10))
1425                        (add-input-to-textView 0 (number->string (modulo n 10))))))))
1426         (add-input-to-textView 0 str))))
1427
1428
1429 ;;;----------------------------------------------------------------------------
1430
1431 ;; Start the main REPL in the primordial thread, and create a second
1432 ;; thread which executes the rest of the program (returning back from
1433 ;; the C call to ___setup) and later takes care of the interaction
1434 ;; with the ViewController.
1435
1436 (continuation-capture
1437  (lambda (cont)
1438
1439    (thread-start!
1440     (make-thread
1441      (lambda ()
1442        (continuation-return cont #f))))
1443
1444    ;; the primordial thread is running this...
1445
1446    (set-navigation-bar '("REPL" "Wiki" "Help" "Edit"))
1447
1448    (set-splash-view) ;; init the splash view
1449    (set-edit-view) ;; init the edit view
1450
1451    (if (equal? CFBundleDisplayName "Gambit REPL dev")
1452        (repo-enable!))
1453
1454    (if (get-pref "run-main-script")
1455
1456        (begin
1457          (set-pref "run-main-script" #f)
1458          (let* ((main-script-name "main")
1459                 (main-script (get-script-by-name main-script-name)))
1460            (if main-script
1461                (begin
1462                  (load-script main-script-name main-script)
1463                  (set-pref "run-main-script" "yes"))
1464                (splash))))
1465
1466        (splash)) ;; show splash screen if main script did not work last time
1467
1468    (##repl-debug-main)
1469
1470    (exit)))
1471
1472
1473 ;;;============================================================================