#!/bin/sh
#|
exec mred -qu $0 "$@"
|#

(module drs-to-ps mzscheme
  (require (lib "file.ss")
           (lib "mred.ss" "mred")
           (lib "framework.ss" "framework")
           (lib "class.ss")
           (lib "pretty.ss")
           (lib "cmdline.ss")
           (prefix pc: (lib "pconvert.ss")))
  
  (define orig-output-port (current-output-port))
  (define (oprintf . x) (apply fprintf orig-output-port x))
  
  (define lang #f)
  (define tps '())
  
  (define (set-font-size pts)
    (let* ([scheme-standard (send (editor:get-standard-style-list) find-named-style "Standard")]
           [scheme-delta (make-object style-delta%)])
      (send scheme-standard get-delta scheme-delta)
      (send scheme-delta set-size-mult 0)
      (send scheme-delta set-size-add pts)
      (send scheme-standard set-delta scheme-delta)))
  
  (define (basename x)
    (let-values ([(base name dir?) (split-path x)])
      (let ([m (regexp-match #rx"(.*)\\.[^.]*$" (path->string name))])
        (if m
            (cadr m)
            (path->string name)))))
  
  (define di-text% scheme:text%)
  (define defs-txt (new di-text%))
  (define ints-txt (new di-text%))

  (send ints-txt freeze-colorer)
  
  (define ps-setup (new ps-setup%))
  (send ps-setup copy-from (current-ps-setup))
  (current-ps-setup ps-setup)

  (define (process-file filename)
    (printf "~a " filename) (flush-output)
    (send defs-txt erase)
    (send ints-txt erase)
    (process-definitions filename)
    (process-interactions filename)
    (printf "done.\n"))
  
  (define (setup-parameters)
    (read-accept-quasiquote (not (equal? lang "htdp-beginner.ss")))
    (error-print-source-location #f)
    (read-decimal-as-inexact #f)
    (read-accept-dot (equal? lang "htdp-advanced.ss")))
  
  (define (process-definitions filename)
    (printf "building program .ps ...  ") 
    (flush-output)
    (let ([base (basename filename)])
      (send defs-txt load-file filename)
      (send defs-txt insert (format ";; ~a\n\n" base) 0 0)
      (send ps-setup set-file (string-append base ".ps"))
      (send defs-txt freeze-colorer)
      (send defs-txt thaw-colorer)
      (send defs-txt print #f #t 'postscript)))
  
  (define (process-interactions filename)
    (let ([base (basename filename)])
      (printf "evaluating program ...  ") (flush-output)
      
      (send defs-txt insert "(module tmp lang\n\n; USERS PROGRAM BEGINS\n" 0 0)
      (send defs-txt insert ";; USERS PROGRAM ENDS\n\n)\n" (send defs-txt last-position) (send defs-txt last-position))
      
      (let ([p (open-output-text-editor defs-txt 0)])
        (pretty-print
         `(module lang mzscheme
            
            (require (prefix #%htdp: (lib ,lang "lang"))
                     ,@(map (λ (tp) `(file ,(path->string (normalize-path tp))))
                            tps))
            
            (provide ,@(map (lambda (x) `(rename ,(symbol-append '#%htdp: x) ,x))
                            exported-lang-names)
                     ,@(map (λ (tp) `(all-from (file ,(path->string (normalize-path tp)))))
                            tps)))
         p)
        (fprintf p "\n\n")
        (flush-output p))
      
      ;(send defs-t freeze-colorer)
      ;(send defs-t thaw-colorer)
      ;(send ps-setup set-file (string-append base "-prog.ps"))  ;; for debugging only
      ;(send defs-t print #f #t 'postscript)
      
      (send ints-txt insert (format ";; ~a\n\n" base) 0 0)
      (let ([op (open-output-text-editor ints-txt (send ints-txt last-position))]
            [ip (open-input-text-editor defs-txt)])
        (setup-parameters)
        (parameterize ([current-output-port op]
                       [current-error-port op]
                       [current-namespace (make-namespace-with-mred)])
          (with-handlers ([exn? (λ (x) ((error-display-handler) (exn-message x) x))])
            (eval (read ip)) ;; eval language
            (let ([m (rewrite-module op (expand (read ip)))])
              (eval m) ;; eval program
              (eval '(require tmp))
              )))
        (flush-output op))
      
      (printf "building output .ps ... ") (flush-output)
      
      (send ps-setup set-file (string-append base "-output.ps"))
      (send ints-txt print #f #t 'postscript)))
  
  (define (set-printing-parameters thunk)
    (parameterize ([pretty-print-columns 50]
                   [pretty-print-size-hook
                    (λ (value display? port)
                      (cond
                        [(is-a? value snip%) 1]
                        [else #f]))]
                   [pretty-print-print-hook
                    (λ (value display? port)
                      (cond
                        [(is-a? value snip%)
                         (write-special value port)
                         1]
                        [else (error)]))]
                   [pc:booleans-as-true/false #t]
                   [pc:constructor-style-printing #t]
                   [pc:abbreviate-cons-as-list (not (equal? lang "htdp-beginner.ss"))]
                   [pc:show-sharing (equal? lang "htdp-advanced.ss")]
                   [pretty-print-show-inexactness #t]
                   [pretty-print-exact-as-decimal #t]
                   [pc:use-named/undefined-handler
                    (lambda (x)
                      (and (equal? lang "htdp-intermediate.ss")
                           (procedure? x)
                           (object-name x)))]
                   [pc:current-print-convert-hook (leave-snips-alone-hook (pc:current-print-convert-hook))]
                   [pc:named/undefined-handler
                    (lambda (x)
                      (string->symbol
                       (format "function:~a" (object-name x))))])
      (thunk)))

  ;; leave-snips-alone-hook : any? (any? -> printable) any? -> printable
  (define ((leave-snips-alone-hook sh) expr basic-convert sub-convert)
    (if (is-a? expr snip%)
        expr
        (sh expr basic-convert sub-convert)))
  
  (define (get-export-names sexp)
    (let* ([sym-name ((current-module-name-resolver) sexp #f #f)]
           [no-ext-name (substring (symbol->string sym-name)
                                   1
                                   (string-length (symbol->string sym-name)))]
           [full-name
            (cond
              [(file-exists? (string-append no-ext-name ".ss"))
               (string-append no-ext-name ".ss")]
              [(file-exists? (string-append no-ext-name ".scm"))
               (string-append no-ext-name ".scm")]
              [(file-exists? no-ext-name)
               no-ext-name]
              [else (error 'htdp-lang.ss "could not find language filename ~s" no-ext-name)])]
           [base-dir (let-values ([(base _1 _2) (split-path full-name)]) base)]
           [stx
            (call-with-input-file full-name
              (lambda (port)
                (read-syntax full-name port)))]
           [code
            (parameterize ([current-load-relative-directory base-dir]
                           [current-directory base-dir])
              (expand stx))]
           [find-name
            (lambda (p)
              (cond
                [(symbol? p) p]
                [(and (pair? p) (pair? (cdr p)))
                 (cadr p)]
                [else (car p)]))])
      (append
       (map find-name (syntax-property code 'module-variable-provides))
       (map find-name (syntax-property code 'module-syntax-provides)))))
  
  (define (symbol-append s1 s2)
    (string->symbol (string-append (symbol->string s1) (symbol->string s2))))
  
  ;; rewrite-module : syntax -> syntax
  ;; rewrites te module to print out results of non-definitions
  (define (rewrite-module op stx)
    (syntax-case stx (module #%plain-module-begin)
      [(module name lang (#%plain-module-begin bodies ...))
       (with-syntax ([(rewritten-bodies ...) 
                      (rewrite-bodies op (syntax->list (syntax (bodies ...))))])
         (syntax (module name lang
                   (#%plain-module-begin 
                    rewritten-bodies ...))))]
      [else
       (raise-syntax-error 'htdp-languages "internal error .1")]))
      
  (define (rewrite-bodies op bodies)
    (let loop ([bodies bodies])
      (cond
        [(null? bodies) null]
        [else
         (let ([body (car bodies)])
           (syntax-case body (require define-values define-syntaxes require-for-syntax provide)
             [(define-values (new-vars ...) e)
              (cons body (loop (cdr bodies)))]
             [(define-syntaxes (new-vars ...) e)
              (cons body (loop (cdr bodies)))]
             [(require specs ...)
              (cons body (loop (cdr bodies)))]
             [(require-for-syntax specs ...)
              (cons body (loop (cdr bodies)))]
             [(provide specs ...)
              (loop (cdr bodies))]
             [else 
              (let ([new-exp
                     (with-syntax ([body body]
                                   [print-results
                                    (lambda results
                                      (for-each (λ (x) (set-printing-parameters (λ () (pretty-print (pc:print-convert x) op))))
                                                results))])
                       (syntax 
                        (call-with-values
                         (lambda () body)
                         print-results)))])
                (cons new-exp (loop (cdr bodies))))]))])))
  
  (define files
    (command-line 
     "drs-to-ps"
     (current-command-line-arguments)
     (once-any
      [("-b" "--beginner") 
       "Use the beginning student language"
       (set! lang "htdp-beginner.ss")]
      [("-i" "--intermediate") 
       "Use the intermediate student language"
       (set! lang "htdp-beginner.ss")]
      [("-a" "--advanced") 
       "Use the advanced student language"
       (set! lang "htdp-beginner.ss")])
     (once-any
      [("-f" "--font") 
       font-size 
       "Sets the font-size"
       (let ([n (string->number font-size)])
         (unless (number? n)
           (error 'drs-to-ps "expectd number for font size, got ~a" n))
         (set-font-size n))])
     (multi
      [("-t" "--teachpack") teachpack-filename
                            "Specify a teachpack"
                            (set! tps (cons teachpack-filename tps))])
     (args (filename . filenames) (cons filename filenames))))
  
  (printf "drs-to-ps (mred version ~a)\n" (version))
  (unless lang
    (error 'drs-to-ps "must pick on the of the langauges. run drs-to-ps --help for details"))

  (define exported-lang-names (get-export-names `(lib ,lang "lang")))
  
  (for-each process-file files))