trying to get the module output working.

whalesong/repl-prototype/htdocs/repl.js

@@ -142,7 +142,7 @@
         var that = this;
         if (compiledResult.type === 'error') {
             return onDoneFail(compiledResult);
-        } else {
+        } else if (compiledResult.type === 'repl') {
             // compiledResult.compiledCodes is an array of function chunks.
             // The evaluation leaves the value register of the machine
             // to contain the list of values from toplevel evaluation.
@@ -165,6 +165,10 @@
                          codeFunction(that.M, onGoodEvaluation, onBadEvaluation);
                      },
                      onDoneSuccess);
+        } else if (compiledResult.type === 'module') {
+            throw new Error("internal error: not yet implemented");
+        } else {
+            throw new Error("internal error: unexpected compilation result");
         }
     };
 

whalesong/repl-prototype/htdocs/rpc.js

@@ -17,12 +17,37 @@
                     });
     };
     
+
+
+    var moduleCompile = function(options, onDone, onDoneError) {
+        jQuery.ajax({ 'url': url,
+                      'cache': false,
+                      'success': function(data, textStatus, jqXHR) { 
+                          onDone(data); 
+                      },
+                      'error': function(jqXHR, textStatus, errorThrown) {
+                          onDoneError(errorThrown); 
+                      },
+                      'data': {'name' : options.name,    // source
+                               'mname' : options.mname,
+                               'lang' : options.lang,
+                               'src' : options.code,
+                               'm' : 't'},
+                      'dataType': 'json',
+                      'type' : 'post'
+                    });
+    };
+
+
+
+
     // If we're in the context of an iframe, provide an easyXDM
     // interface to the compiler.
     if (window.top !== window) {
         new easyXDM.Rpc({}, {
             local: {
-                'replCompile': { method: replCompile }
+                'replCompile': { method: replCompile },
+                'moduleCompile': { method: moduleCompile }
             }
         });
     }

whalesong/repl-prototype/modularize-input-port.rkt

@@ -0,0 +1,53 @@
+#lang racket/base
+ 
+(require racket/port
+         racket/contract)
+ 
+(provide (contract-out [modularize-input-port (-> 
+                                               #:module-name symbol?
+                                               #:input-port input-port?
+                                               #:semantics-module symbol? 
+                                               input-port?)]))
+                                
+;; Add a module wrapper around s-expression-based toplevel code, but
+;; preserving original source locations as best as we can.
+(define (modularize-input-port #:module-name name    ;; symbol
+                               #:input-port ip       ;; input port
+                               #:semantics-module semantics-module)          ;; symbol
+  (define header (format "(module ~s ~s\n" name semantics-module))
+  (define lang-ip (open-input-string header))
+  
+  (define concatenated-port (input-port-append #f lang-ip ip (open-input-string ")")))
+  (define (count-concatenated-port)
+    (port-count-lines! concatenated-port))
+
+  (define (get-location)
+    (define-values (line column position) (port-next-location concatenated-port))
+    (cond [(not (and line column position))
+           (values #f #f #f)]
+          [(<= position (string-length header))
+           (values #f #f #f)]
+          [else
+           (port-next-location ip)]))
+  
+  (define-values (starting-line starting-col starting-pos)
+    (port-next-location ip))
+  (transplant-input-port concatenated-port 
+                         get-location 
+                         (or starting-pos 1)
+                         #f 
+                         count-concatenated-port))
+ 
+ 
+(module* test racket/base
+  (require (submod "..")
+           racket/port)
+  (define original-ip (open-input-string "(+ 1\n 2)"))
+  (port-count-lines! original-ip)
+  (define relocated-ip (relocate-input-port original-ip 5 1 200))
+  (port-count-lines! relocated-ip)
+  (define new-ip (modularize-input-port #:module-name 'test
+                                        #:input-port relocated-ip #;original-ip
+                                        #:semantics-module 'wescheme))
+  (port-count-lines! new-ip)
+  (read-syntax #f new-ip))

whalesong/repl-prototype/server.rkt

@@ -1,7 +1,6 @@
 #lang racket/base
 
-(require "repl-compile.rkt"
+(require json
-         json
          file/gzip
          racket/runtime-path
          racket/port
@@ -9,6 +8,8 @@
          racket/pretty
          web-server/servlet-env
          web-server/servlet
+         "repl-compile.rkt"         
+         "modularize-input-port.rkt"
          "../make/make-structs.rkt"
          "../js-assembler/package.rkt"
          "../parser/parse-bytecode.rkt"
@@ -63,14 +64,18 @@
             out))
 
 
+(define (lookup-binding req id)
+  (if (exists-binding? 'id (request-bindings req))
+      (extract-binding/single 'id (request-bindings req))
+      #f))
 
 (define (start req)
   (define-values (response op) 
     (make-port-response #:mime-type #"text/json" #:with-cors? #t))
-  (define name (if (exists-binding? 'name (request-bindings req))
+  (define source-name (lookup-binding req 'name))
-                   (extract-binding/single 'name (request-bindings req))
+  (define mname (lookup-binding req 'mname))
-                   #f))
+  (define lang (lookup-binding req 'lang))
-  (define text-src (extract-binding/single 'src (request-bindings req)))
+  (define src (extract-binding/single 'src (request-bindings req)))
   (define as-mod? (match (extract-bindings 'm (request-bindings req))
                     [(list (or "t" "true"))
                      #t]
@@ -81,11 +86,11 @@
                                                  'message (exn-message exn))
                                            op))])
     (cond [(not as-mod?)
-           (define ip (open-input-string text-src))
+           (define ip (open-input-string src))
            (port-count-lines! ip)
            (define assembled-codes
              (let loop () 
-               (define sexp (read-syntax name ip))
+               (define sexp (read-syntax source-name ip))
                (cond [(eof-object? sexp)
                       '()]
                      [else
@@ -104,17 +109,22 @@
                              'compiledCodes assembled-codes)
                        op)]
           [else
-           (define program-port (open-output-string))
+           (define program-input-port
+             (let* ([ip (open-input-string src)])
+               (port-count-lines! ip)
+               (modularize-input-port #:module-name (string->symbol mname)
+                                      #:input-port ip
+                                      #:semantics-module 'whalesong)))
+           (define program-output-port (open-output-string))[
            (package (SexpSource (parameterize ([read-accept-reader #t])
-                                  (read (open-input-string (string-append "#lang whalesong\n" text-src)))))
+                                  (read-syntax source-name program-input-port)))
                     #:should-follow-children? (lambda (src) #f)
-                    #:output-port  program-port)
+                    #:output-port  program-output-port)
            (write-json (hash 'type "module"
-                             'compiledModule (get-output-string program-port))
+                             'module-name (string->symbol mname)
-                       op)
+                             'provides ()  ;; FIXME!
-           ]))
+                             'compiledModule (get-output-string program-output-port))
-  ;; Send it back as json text....
+                       op)]))
-
   (close-output-port op)
   response)
   
@@ -140,4 +150,4 @@
          [("-p" "--port") p "Port (default 8000)" 
           (current-port (string->number p))]))
   (start-server #:port (current-port)))
-  
+