;;;============================================================================ ;;; File: "program.scm" ;;; Copyright (c) 2011-2015 by Marc Feeley, All Rights Reserved. ;; This program implements the "Gambit REPL" application for iOS ;; devices. It is a simple development environment for Scheme. The ;; user can interact with a REPL, and edit small scripts. ;;;============================================================================ (##namespace ("gr#")) (##include "~~lib/gambit#.scm") (##include "~~lib/_gambit#.scm") (##namespace ("gr#" help)) ;; don't import help (##include "wiki#.scm") (##include "html#.scm") (##include "url#.scm") (##include "json#.scm") (##include "repl-server#.scm") (##include "intf#.scm") (##include "script#.scm") (##include "repo#.scm") (##include "help#.scm") (##include "emacs#.scm") (##namespace ("" splash set-page set-page-content repl repl-eval repl-server wiki help edit reset-scripts remove-script store-script fetch-script view-script emacs )) (declare (standard-bindings) (extended-bindings) (block) (fixnum) ;;(not safe) ) ;;;---------------------------------------------------------------------------- ;; Add cond-expand features to identify Gambit-REPL. (set! ##cond-expand-features (cons 'GambitREPL (cons 'GambitREPL-iOS (cons 'GambitREPL-v4.0 ##cond-expand-features)))) (define-runtime-syntax |\u03bb| ;; greek lowercase lambda (##make-alias-syntax '##lambda)) ;;;---------------------------------------------------------------------------- ;; Common HTML header. (define common-html-header #< common-html-header-end ) ;;;---------------------------------------------------------------------------- ;; Splash page. (define splash-page-content-part1 #<

Welcome to splash-page-content-part1-end ) (define splash-page-content-part2 #<, a Scheme development environment based on the Gambit Scheme programming system.

learn the Scheme language,
debug Scheme code on the go,
number crunch exactly!

In the REPL view, enter your command after the > prompt, then tap return to display the result. Here is a sample interaction:
> (+ 1 (/ (* 2 2) (sqrt 9))) 7/3 > (expt 2 100) 1267650600228229401496703205376 > (reverse (string->list "hello")) (#\o #\l #\l #\e #\h) > \for (int i=1;i<=3;i++) pp(i*i); 1 4 9
splash-page-content-part2-end ) (define (set-splash-view) (set-view-content 0 (list common-html-header splash-page-content-part1 CFBundleDisplayName splash-page-content-part2) #f #t)) (define (splash) (set-navigation -1) (set-event-handler (lambda (old-event-handler) (lambda (event) (cond ((equal? event "event:foo") (eval-js-in-webView 0 (string-append "alert('handler')"))) (else (generic-event-handler event)))))) (show-view 0)) (define (set-page content handler #!optional (enable-scaling #f) (mime-type "text/html")) (set-view-content 0 content #f enable-scaling mime-type) (set-navigation -1) (set-event-handler (lambda (old-event-handler) handler)) (show-view 0)) (define (set-page-content content #!optional (enable-scaling #f) (mime-type "text/html")) (set-page content generic-event-handler enable-scaling mime-type)) ;;;---------------------------------------------------------------------------- ;; Help page. (define current-help-document #f) (define (help #!optional (subject (macro-absent-obj))) (if (eq? subject (macro-absent-obj)) (show-help-document (or current-help-document main-help-document) #f) (##help subject))) (define (show-help-document docu anchor) (let ((load-docu? (not (equal? docu current-help-document)))) (define (goto-anchor) (if anchor (eval-js-in-webView 2 (string-append "window.location='#" anchor "'")))) (set-event-handler (lambda (old-event-handler) (lambda (event) (cond ((and load-docu? (equal? event "event:loaded")) (if (not (equal? docu main-help-document)) (show-cancelButton)) (goto-anchor)) ((equal? event "event:r5rs") (show-help-document r5rs-help-document #f)) ((equal? event "event:gambit") (show-help-document gambit-help-document #f)) ((equal? event "cancel") (hide-cancelButton) (show-help-document main-help-document #f)) ((has-prefix? event "event:browse:") => (lambda (rest) (open-URL rest))) ((wiki-event-handler event)) ((handle-create-account-event event)) (else (handle-navigation-event event (lambda () (hide-cancelButton)))))))) (if load-docu? (begin (set! current-help-document docu) (set-webView-content-from-file 2 docu (path-directory docu) #t)) (goto-anchor)) (set-navigation 2) (show-view 2) (if (not (equal? docu main-help-document)) (show-cancelButton)))) ;;;---------------------------------------------------------------------------- ;; REPL page. (define (repl) (set-navigation 0) (set-event-handler (lambda (old-event-handler) generic-event-handler)) (show-textView 0 #t #t)) (define (repl-eval str) (if (string? str) (begin (add-output-to-textView 0 str) (send-input str) (repl)))) (define (repl-server password) (repl-server-start password)) (set! ##primordial-exception-handler-hook (lambda (exc other-handler) (if (##eq? (##thread-repl-channel-get! (macro-primordial-thread)) (##thread-repl-channel-get! (macro-current-thread))) (repl)) ;; switch to REPL view on errors (##repl-exception-handler-hook exc other-handler))) ;;;---------------------------------------------------------------------------- ;; Script editor. (define edit-page-content-part1 #< edit-page-content-part1-end ) (define edit-page-content-part2 #<

+
edit-page-content-part4-end ) (define edit-page-content-part5 #< edit-page-content-part5-end ) (define edit-page-script-rows-iPad 20) (define edit-page-script-rows-default 10) (define edit-page-script-rows (case (device-model) ((iPad) edit-page-script-rows-iPad) (else edit-page-script-rows-default))) (define (html-for-local-scripts scripts) (define (html script name index) (list "
\n" "" (html-escape script) "\n" "\n" "
Run
\n" "       " "
Save
\n" "       " "
Delete
\n" "\n")) (let loop ((scripts scripts) (i 0) (accum '())) (if (pair? scripts) (let* ((x (car scripts)) (name (car x)) (script (cdr x))) (loop (cdr scripts) (+ i 1) (cons (html (add-script-name-if-needed name script) name i) accum))) (reverse accum)))) (define (add-script-name-if-needed name script) (if (not (wiki-script-name-type name)) script (let ((name-in-script (extract-script-name script))) (if (equal? name name-in-script) script (string-append script-name-prefix name "\n\n" script))))) (define (set-edit-view) (set-view-content 3 (let ((scripts (get-script-db))) (list common-html-header edit-page-content-part1 "var nb_scripts = " (length scripts) ";\n" edit-page-content-part2 (if repo-enabled? edit-page-content-part3 "") edit-page-content-part4 (html-for-local-scripts scripts) edit-page-content-part5)) #f #t)) (define (edit) (set-navigation 3) (set-event-handler (lambda (old-event-handler) (lambda (event) (handle-edit-event event (lambda () (generic-event-handler event (lambda () (let ((new-event (eval-js-in-webView 3 "lose_focus()"))) (and (string? new-event) (handle-edit-event new-event (lambda () #f))))))))))) (show-view 3 #t) (eval-js-in-webView 3 "gain_focus()")) (define (get-index-and-update-script-db rest) (let ((x (get-event-parameters rest))) (if (pair? x) (let ((index (string->number (car x)))) (let loop ((lst (cdr x)) (rev-scripts '())) (if (pair? lst) (let ((script (car lst))) (loop (cdr lst) (cons (cons (extract-script-name script) script) rev-scripts))) (let ((new-script-db (reverse rev-scripts))) (set-pref "run-main-script" "yes") (set! script-db new-script-db) (save-script-db) index)))) #f))) (define (handle-edit-event event otherwise) (cond ((has-prefix? event "event:new:") => (lambda (rest) (get-index-and-update-script-db rest) (new-script) (set-edit-view))) ((has-prefix? event "event:run:") => (lambda (rest) (run-script-event (get-index-and-update-script-db rest)))) ((has-prefix? event "event:save:") => (lambda (rest) (save-script-event (get-index-and-update-script-db rest)))) ((has-prefix? event "event:remove:") => (lambda (rest) (remove-script-event (get-index-and-update-script-db rest)))) ((has-prefix? event "event:delete:") => (lambda (rest) (delete-script-event (get-index-and-update-script-db rest)) (set-edit-view))) ((has-prefix? event "event:exit:") => (lambda (rest) (get-index-and-update-script-db rest))) (else (otherwise)))) (define (handle-navigation-event event lose-focus-handler) (let ((nav (has-prefix? event "NAV"))) (if nav (let ((n (string->number nav))) (lose-focus-handler) (case n ((1) (wiki)) ((2) (help)) ((3) (edit)) (else (repl))))))) (define (wiki-event-handler event) (or (and (equal? event "event:wiki") (begin (visit-wiki) #t)) (and (equal? event "event:wiki-Gambit-REPL") (begin (visit-wiki-Gambit-REPL) #t)))) (define (visit-wiki) (open-URL (string-append "http://" wiki-server-address wiki-root "/index.php"))) (define (visit-wiki-Gambit-REPL) (open-URL (string-append "http://" wiki-server-address wiki-root "/index.php/Gambit_REPL"))) (define latest-pasteboard #f) (define (handle-app-become-active-event event) (and (equal? event "app-become-active") (let* ((script (get-pasteboard)) (name (and script (not (equal? script latest-pasteboard)) (extract-script-name script)))) (set! latest-pasteboard script) (if name (set-event-handler (lambda (old-event-handler) (popup-alert (string-append CFBundleName ".app") (string-append "Create the script\n\n" name "\n\nin the Edit view from the content of the pasteboard?") "No" "Yes") (lambda (event) (define (done accept?) (set-event-handler (lambda (new-event-handler) old-event-handler)) (if accept? (begin (add-script name script) (set-edit-view) (edit)))) (cond ((equal? event "popup-alert-cancel") (done #f)) ((equal? event "popup-alert-accept") (done #t))))))) #t))) (define (handle-create-account-event event) (and (equal? event "event:create-account") (begin (open-URL (string-append "http://" wiki-server-address wiki-root "/index.php/Special:RequestAccount")) #t))) (define (handle-icloud-event event) (cond ((equal? event "iCloudAccountAvailabilityChanged") (iCloudAccountAvailabilityChanged) #t) ((has-prefix? event "iCloudContainerDirChanged:") => (lambda (rest) (iCloudContainerDirChanged rest) #t)) (else #f))) (define (handle-soft-keyboard-event event) (and (or (equal? event "soft-keyboard-show") (equal? event "soft-keyboard-hide")) (begin (popup-alert (string-append CFBundleName ".app") "The keyboard has changed" "OK" #f) #t))) (define (generic-event-handler event #!optional (lose-focus-handler (lambda () #f))) (or (wiki-event-handler event) (handle-app-become-active-event event) (handle-icloud-event event) (handle-soft-keyboard-event event) (handle-create-account-event event) (handle-navigation-event event lose-focus-handler))) (define run-script-event #f) (set! run-script-event (lambda (index) (let ((name-script (get-script-at-index index))) (and name-script (let ((name (car name-script)) (script (cdr name-script))) (run-script name script)))))) (define save-script-event #f) (set! save-script-event (lambda (index) (let ((name-script (get-script-at-index index))) (and name-script (let ((name (car name-script)) (script (cdr name-script))) (store-script name script edit)))))) (define remove-script-event #f) (set! remove-script-event (lambda (index) (let ((name-script (get-script-at-index index))) (and name-script (let ((name (car name-script)) (script (cdr name-script))) (remove-script name edit)))))) (define (reset-scripts) (script#reset-scripts) (set-edit-view)) (define (remove-script name #!optional (back repl)) (case (wiki-script-name-type name) ((wiki) (repo-transaction (lambda () (wiki-script-name-verify name) (wiki-script-remove name) (back)) "" (list "
Removing script
" (html-escape name) "
") "The script has been removed from the Gambit wiki" "Could not remove script!" back)) ((file) (with-exception-catcher (lambda (e) (display-exception e (repl-output-port)) (repl)) (lambda () (delete-file (##path-expand name "~")))) (back)))) (define (store-script name script #!optional (back repl)) (case (wiki-script-name-type name) ((wiki) (repo-transaction (lambda () (wiki-script-name-verify name) (wiki-script-store name script) (back)) "" (list "
Storing script
" (html-escape name) "
") "The script has been stored on the Gambit wiki" "Could not store script!" back)) ((file) (with-exception-catcher (lambda (e) (display-exception e (repl-output-port)) (repl)) (lambda () (call-with-output-file (##path-expand name "~") (lambda (port) (display script port))))) (back)))) (define (fetch-script name #!optional (back repl)) (case (wiki-script-name-type name) ((wiki) (repo-transaction (lambda () (wiki-script-name-verify name) (let ((script (wiki-script-fetch name))) (add-script name script) (set-edit-view) (back))) "" (list "
Fetching script
" (html-escape name) "
") "The script has been fetched from the Gambit wiki" "Could not fetch script!" back)) ((file) (with-exception-catcher (lambda (e) (display-exception e (repl-output-port)) (repl)) (lambda () (let ((script (call-with-input-file (##path-expand name "~") (lambda (port) (read-line port #f))))) (add-script name script) (set-edit-view) (back)))) (back)))) (define (delete-script-event index) (let loop ((scripts (get-script-db)) (i 0) (accum '())) (if (pair? scripts) (if (= i index) (set! script-db (append (reverse accum) (cdr scripts))) (loop (cdr scripts) (+ i 1) (cons (car scripts) accum))))) (save-script-db)) (define script-name-prefix ";;; ") ;; must be consistent with the definition of the click_save JavaScript function (define (extract-script-name script) (let* ((line1 (first-line script)) (name (has-prefix? line1 script-name-prefix))) (and (wiki-script-name-type name) name))) (define (first-line str) (let loop ((i 0)) (if (< i (string-length str)) (if (char=? (string-ref str i) #\newline) (substring str 0 i) (loop (+ i 1))) str))) ;;;---------------------------------------------------------------------------- ;; Repository browser. (define repo-page-content-part1 #<
repo-page-content-part1-end ) (define repo-page-content-part2 #<
◀
repo-page-content-part2-end ) (define repo-page-content-part3 #< repo-page-content-part3-end ) (define repo-page-content-part4 #< repo-page-content-part4-end ) (define repo-page-content-part5 #< repo-page-content-part5-end ) (define (html-for-script-tree tree) (define (html branch) (let ((name (car branch)) (subtree (cdr branch))) (list "" (if (pair? subtree) (list "\n" "\n") (list "\n" "\n")) "\n" "\n"))) (let loop ((tree tree) (accum '())) (if (pair? tree) (let ((branch (car tree))) (loop (cdr tree) (cons (html branch) accum))) (reverse accum)))) (define repo-enabled? #f) (define (repo-enable!) (if (not repo-enabled?) (begin (set! repo-enabled? #t) (segm-ctrl-set-title 1 "Repo")))) (define (repo) (repo-enable!) (wiki)) (define (wiki) (if (not repo-enabled?) (begin (visit-wiki-Gambit-REPL) (repl)) (repo-transaction (lambda () (let ((scripts (wiki-script-list))) (repo-browse #f (script-list->tree scripts)))) repo-page-content-part3 (list "
Accessing Gambit wiki

") #f "Could not get list of scripts!" repl))) (define (script-list->tree scripts) (define (cvt scripts prefix) (if (not (pair? scripts)) '() (let ((script1 (car scripts))) (let loop1 ((i 0)) (if (< i (string-length script1)) (if (not (char=? (string-ref script1 i) #\:)) (loop1 (+ i 1)) (let ((p (substring script1 0 (+ i 1)))) (let loop2 ((lst scripts) (rev-subtrees '())) (define (end) (let ((new-prefix (string-append prefix p))) (cons (cons new-prefix (cvt (reverse rev-subtrees) new-prefix)) (cvt lst prefix)))) (if (pair? lst) (let ((s (car lst))) (if (and (<= i (string-length s)) (string=? (substring s 0 (+ i 1)) p)) (loop2 (cdr lst) (cons (substring s (+ i 1) (string-length s)) rev-subtrees)) (end))) (end))))) (cons (cons (string-append prefix script1) '()) (cvt (cdr scripts) prefix))))))) (cvt scripts "")) (define (repo-browse back tree) (set-navigation 1) (set-event-handler (lambda (old-event-handler) (lambda (event) (cond ((has-prefix? event "event:view:") => (lambda (rest) (let* ((params (get-event-parameters rest)) (name (car params)) (branch (assoc name tree))) (if branch (let ((subtree (cdr branch))) (if (pair? subtree) (repo-browse (lambda () (repo-browse back tree)) subtree) (view-script name))))))) ((has-prefix? event "event:get:") => (lambda (rest) (let* ((params (get-event-parameters rest)) (name (car params))) (get-repo-script-event name edit)))) ((equal? event "event:back") (back)) (else (generic-event-handler event)))))) (set-view-content 1 (list common-html-header repo-page-content-part1 (if back repo-page-content-part2 repo-page-content-part3) repo-page-content-part4 (html-for-script-tree tree) repo-page-content-part5) #f #t) (show-view 1 #t)) (define (view-script name) (open-URL (string-append "http://" wiki-server-address wiki-root "/index.php/" (url-encode (string-append wiki-script-prefix name))))) (define get-repo-script-event #f) (set! get-repo-script-event fetch-script) ;;;---------------------------------------------------------------------------- ;; Repository transaction page. (define repo-transaction-page-content-part1 #< repo-transaction-page-content-part1-end ) (define repo-transaction-page-content-part2 #<

repo-transaction-page-content-part2-end ) (define repo-transaction-page-content-part3 #<
repo-transaction-page-content-part3-end ) (define (make-repo-transaction-page header msg status) (list common-html-header repo-page-content-part1 header repo-transaction-page-content-part1 msg repo-transaction-page-content-part2 status repo-transaction-page-content-part3)) (define (repo-transaction thunk header msg success-msg failure-msg back) (define (exec) (let ((content (make-repo-transaction-page header msg spinner-html))) (set-navigation 1) (set-view-content 1 content #f #t) (show-view 1 #t)) (guard-repo-transaction (lambda () (thunk) (if success-msg (begin (set-view-content 1 (make-repo-transaction-page header msg (list "
" success-msg "
")) #f #t) (thread-sleep! 2) ;; display success message for 2 seconds (back)))) header msg failure-msg back)) (auto-login exec back)) (define (guard-repo-transaction thunk header msg failure-msg back) (with-exception-catcher (lambda (e) (set-view-content 1 (make-repo-transaction-page header msg (list "
" failure-msg "

" (exception->error-msg e) "
")) #f #t) (thread-sleep! 4) ;; display error message for 4 seconds (back)) thunk)) (define spinner-html "
") (define (exception->error-msg e) (cond ((equal? e "NotExists") "Username does not exist") ((or (equal? e "NoName") (equal? e "Illegal")) "Illegal username") ((or (equal? e "EmptyPass") (equal? e "WrongPass") (equal? e "WrongPluginPass")) "Wrong password") ((or (equal? e "Blocked") (equal? e "CreateBlocked")) "This user is blocked") ((equal? e "Throttled") "Too many logins... try again later") ((equal? e "failed to connect") "Could not connect to Gambit wiki") ((equal? e "script not found") "Script not found") ((equal? e "malformed script") "Script is not properly formatted") ((equal? e "you must first login to the Gambit wiki") "Not logged in to the Gambit wiki") ((or (equal? e "script name must be a string") (equal? e "script name must end with \".scm\"") (equal? e "script name must start with an upper case letter") (equal? e "script name must contain at least one colon") (equal? e "illegal character in script name")) "Invalid script name") ((equal? e "unknown") "Unknown error") (else (with-output-to-string "" (lambda () (display-exception e)))))) ;;;---------------------------------------------------------------------------- ;; Repository login. (define login-page-content-part1 #<

Log in to Gambit wiki

▶
Get
View
" (html-escape name) "

Username:
Password:
Remember my password


login-page-content-part4-end ) (define login-page-content-part5 #<
If you don't have an account, you should

Create an account

It's free! login-page-content-part5-end ) (define (make-login-page username password remember-pass? msg) (list common-html-header login-page-content-part1 (html-escape username) login-page-content-part2 (html-escape password) login-page-content-part3 (if remember-pass? "checked " "") login-page-content-part4 msg login-page-content-part5)) (define (make-initial-login-page) (let ((info (get-login-info))) (make-login-page (car info) (cadr info) (caddr info) ""))) (define (auto-login success fail) (if (wiki-logged-in?) (success) (login success fail))) (define (login #!optional (success repl) (fail repl)) (login-with-page (make-initial-login-page) success fail)) (define (login-with-page page success fail) (set-navigation 1) (set-event-handler (lambda (old-event-handler) (lambda (event) (cond ((has-prefix? event "event:login:") => (lambda (rest) (let* ((params (get-event-parameters rest)) (username (car params)) (password (cadr params)) (remember-pass? (equal? (caddr params) "on"))) (attempt-login success fail username password remember-pass?)))) ((equal? event "event:cancel") (fail)) (else (generic-event-handler event)))))) (set-view-content 1 page #f #t) (show-view 1 #t)) (define (attempt-login success fail username password remember-pass?) (set-login-info username password remember-pass?) (save-login-info) (set-view-content 1 (make-login-page username password remember-pass? spinner-html) #f #t) ((with-exception-catcher (lambda (e) (let ((msg (list "
" (exception->error-msg e) "
"))) (lambda () (login-with-page (make-login-page username password remember-pass? msg) success fail)))) (lambda () (wiki-logout) (wiki-login username password #t) (set-view-content 1 (make-login-page username password remember-pass? "
You are now logged in!
") #f #t) (thread-sleep! 2) ;; display success message for 2 seconds success)))) ;;;---------------------------------------------------------------------------- ;; Opening URLs. (##namespace ("" open-URL)) (define (open-URL str) (if (string? str) (intf#open-URL str))) ;;;---------------------------------------------------------------------------- ;; Emacs. (##namespace ("" emacs)) (define (emacs . files-to-visit) (apply emacs#emacs files-to-visit)) ;;;---------------------------------------------------------------------------- ;; Input handlers. (set! handle-text-input (lambda (str) (add-text-input-to-currentView str))) (set! handle-key-input (lambda (str) (cond ((char=? #\F (string-ref str 0)) (let ((script (get-script-by-name str))) (if script (run-script str script) (cond ((string=? str "F12") (##thread-interrupt! (macro-primordial-thread))) (else (add-key-input-to-currentView str)))))) ((and (char=? #\M (string-ref str 0)) (not (equal? CFBundleDisplayName "Not Emacs"))) (let ((n (string->number (substring str 1 (string-length str))))) (cond (n (if (> n 0) (send-event (string-append "NAV" (number->string (- n 1)))) (toggle-toolbar))) (else (add-key-input-to-currentView str))))) (else (add-key-input-to-currentView str))))) ;;;---------------------------------------------------------------------------- ;; Start the main REPL in the primordial thread, and create a second ;; thread which executes the rest of the program (returning back from ;; the C call to ___setup) and later takes care of the interaction ;; with the ViewController. (continuation-capture (lambda (cont) (thread-start! (make-thread (lambda () (continuation-return cont #f)))) ;; the primordial thread is running this... (set-navigation-bar '("REPL" "Wiki" "Help" "Edit")) (if (not (equal? CFBundleDisplayName "Gambit REPL")) (repo-enable!)) (set-splash-view) ;; init the splash view (set-edit-view) ;; init the edit view (add-output-to-textView 0 "\n\n\n") ;; leave space at top of REPL view (if (equal? CFBundleDisplayName "Not Emacs") (emacs) (begin (show-toolbar) (cond ((get-pref "run-main-script") (set-pref "run-main-script" #f) (let* ((main-script-name "main") (main-script (get-script-by-name main-script-name))) (if main-script (begin (load-script main-script-name main-script) (set-pref "run-main-script" "yes")) (splash)))) (else (splash))))) ;; show splash screen if main script did not work last time (##repl-debug-main))) ;;;============================================================================