;; builtin languages: toplevel image and sandbox

(module box scheme/base
  
  (require
   scheme/sandbox
   scheme/pretty
   scheme/control
   syntax/stx
   (lib "match.ss")
   "language.ss"
   "emacs-channel.ss"
   "util.ss")

  ;; (provide (all-defined))
  (provide box-module-string  ;; instantiate module string in sandbox
           box-module-file    ;;             .. from file ..
           box-toplevel       ;; clean mzscheme toplevel in sandbox
           box-mb
           box-sec
           box-load
           box-eval
           box-break
           )


  ;; MODULE SANDBOX LANGUAGE INTERFACE

  ;; This uses make-evaluator from sandbox.ss to create an evaluator
  ;; for a module namespace. Overwriting the evaluator erases the
  ;; sandbox.
  
  (define *box-evaluator* #f)
  (define *box-expansion* #f)  ;; keep it outside the evaluator

  (define (box-evaluator) *box-evaluator*)

  (define (box-break) (break-evaluator *box-evaluator*))
  (define (box-kill)  (kill-evaluator *box-evaluator*))

  (define (set-box-eval! thunk)
    (when *box-evaluator*
      ;; FIXME: this first needs to shut down all the threads that are
      ;; currently using the evaluator (i.e. interpreting emacs
      ;; commands).
      (box-break)
      (box-kill)
      (collect-garbage)
      (printf "Killed previous evaluator.\n"))
    (set! *box-evaluator* (thunk)))

  (define (box-eval expr)
    (unless *box-evaluator*
      (error 'box-not-active))
    (*box-evaluator* expr))


  

  ;; rest uses accessors
  
  (define (set-box-limits! sec mb)
    (sandbox-eval-limits
     (and (or sec mb)
          `(,sec ,mb)))
    (let ((e (box-evaluator)))
      (when e (set-eval-limits e sec mb))))

  ;; Default: unlimited
  (sandbox-eval-limits (list #f #f))


  (define box-complete
    (make-completer
     (lambda ()
       (let ((e (box-evaluator)))
         ((if e e eval) ;; fallback; don't fail
          '(namespace-mapped-symbols))))))
  
  (define (box-repl str)
    (eval-repl box-eval str))


  (define (box-macro-repl str)
    (if (equal? str "")
        (box-expand-again!)
        (begin
          ;; Keep syntax local to evaluator
          (set-box-expansion!
            (parameterize
                ((read-accept-reader #t))
              (read (open-input-string str))))
          (box-expand-again!))))
  
  (define (box-expansion) *box-expansion*)
  (define (set-box-expansion! expr) (set! *box-expansion* expr))

  (define (box-expand-once!)
    (set-box-expansion!
     (box-eval `(expand-once ',(box-expansion)))))
  
  (define (box-expand-again!)
    (box-expand-once!)
    (pp
     (syntax->datum
      (box-expansion))))

    
  (register-language 'box
                     "box> "
                     box-eval
                     box-repl
                     box-complete)

  (register-language 'box-macro
                     "box-macro> "
                     #f ;; box-eval  ;; ???
                     box-macro-repl
                     box-complete)


  
  ;; Needs to set the current load path to make sure relative require
  ;; file names work.

  (define (box-read path port)
    (parameterize*
     ((current-directory (or path (current-directory)))
      (current-load-relative-directory (current-directory))
      (read-accept-reader #t))  ;; should this be always enabled?

     (let* ((expr (read port)))
       ;; Fail if there are multiple expressions: this probably means
       ;; a paren error in an emacs module buffer.
       (unless (eof-object? (read port))
         (error 'box-read-multiple-expressions))
       
       (set-box-eval! (lambda () (make-eval expr))))))
  

  (define (box-module-string path str)
    (box-read path (open-input-string str)))

  (define (box-module-file path filename)
    (box-read path (open-input-file filename)))


  (define (box-toplevel [code '(begin)])
    (set-box-eval!
     (lambda () (make-eval 'scheme/base code))))
    
  ;; Set current and subsequent limits.  The default is off, since
  ;; this implementation uses a custodian which will close down ports
  ;; per evaluation.
  
  (define box-mb
    (make-parameter #f
                    (lambda (mb)
                      (set-box-limits! (box-sec) mb)
                      mb)))
      
  (define box-sec
    (make-parameter #f
                    (lambda (sec)
                      (set-box-limits! sec (box-mb))
                      sec)))

  ;; Be permissive for read-only access.
  (define (allow-path p)
    (for/list ((action '(execute read-bytecode read exists)))
              (list action p)))
    
  
  (define (call-with-sandbox-parameters thunk)
    (parameterize
        ((sandbox-security-guard (current-security-guard))
         ;; (sandbox-eval-limits (list (box-sec) (box-mb))) ;; set permanently
         (sandbox-path-permissions (allow-path "/"))
         (sandbox-output *log-emacs*))
      (call-with-trusted-sandbox-configuration thunk)))


  ;; Create evaluator
  (define (make-eval . args)
    (let ((eval
           (call-with-sandbox-parameters
            (lambda ()
              (printf "Evaluation limits: ~a.\n" (sandbox-eval-limits))
              (apply 
               (match args
                      (((module . _)) make-module-evaluator)
                      (_              make-evaluator))
               args)))))
      
      ;; extend the evaluator's environment
      (eval '(require scheme/enter))
      ;; (eval '(compile-enforce-module-constants #f))

      ;; fish out toplevel commands
      (lambda (expr)
        (syntax-case expr (unquote)
          ((unquote _) (box-command (cadr expr)))
          (_ (eval expr))))))
           
             

  ;; BOX COMMANDS

  ;; I don't think toplevel variables are so useful as box
  ;; commands. Use parameters instead. This allows naked symbols to be
  ;; converted to thunks, or if not defined, to filenames.
  
  (define (box-command cmd)
    (cond
     ((or (path? cmd)
          (string? cmd)) ((box-load) cmd))
     ((list? cmd) (eval cmd))
     (else
      (let ((thunk
             (namespace-variable-value
              cmd #t
              (lambda ()
                (lambda ()
                  ((box-load) (format "~a" cmd)))))))
        (thunk)))))
    
  (define box-load (make-parameter load/cd))
  
  
  
  )