;; basescheme.ss
;;
;; @author  Morgan McGuire, morgan@cs.brown.edu
;;
;; @created 2002-01-15
;; @edited  2002-01-15
;;
;; Basic Scheme environment used for the foolproofscheme transformation 
;; environment.  Don't require directly; use foolproofscheme.
;;

(module basescheme mzscheme
        (require (lib "unitsig.ss")
                 (lib "url.ss" "net")
                 (lib "string.ss")
                 (lib "list.ss")
                 (lib "etc.ss")
                 (lib "base64.ss" "net")
                 (lib "file.ss")
                 (lib "pretty.ss"))

        (require-for-syntax (lib "list.ss"))
         
        (provide (all-from (lib "list.ss"))
                 (all-from (lib "string.ss"))
                 (all-from (lib "file.ss"))
                 (all-from (lib "pretty.ss"))
                 (all-from mzscheme)
                 define-macro
                 reparse-for-colons
                 retokenize-for-colons
                 symbol-remove-first
                 string-index
                 print-to-string
                 neq?
                 proc?)

(define (neq? a b)
   (not (eq? a b)))

(define proc? procedure?)

(define (print-to-string x)
  (let* 
      ([out    (open-output-string)]
       [result (begin
                 (print x out)
                 (get-output-string out))])
    (close-output-port out)
    result))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; define-macro like the one that was in 1.0 PLT Scheme;
;; allows you to directly walk the parse tree.
;;
;; This is needed for proc.
(define-syntax define-macro
 (syntax-rules ()
  [(_ (macro-name arg) m1 m2 ...)
   
   
   (define-syntax (macro-name expr)
     (syntax-case expr ()  ;; () = no keywords to match against
       [(_ body1 body2 (... ...))  ;; always use _ for keyword position
        (datum->syntax-object
         expr
         ((lambda (arg) m1 m2 ...)
          
          (syntax-object->datum
           (syntax (body1 body2 (... ...)))))
         expr
         expr)]))

   
   ]))



;(define-syntax define-macro
;  (syntax-rules 
;   ()
;   [(_ (macro-name arg) m1 m2 ...)
;    
;    
;    (define-syntax (macro-name expr)
;      (syntax-case expr ()  ;; () = no keywords to match against
;        [(_ body1 body2 (... ...))  ;; always use _ for keyword position
;         (datum->syntax-object
;          expr
;          (
;           
;           (lambda (arg) m1 m2 ...)
;           
;           (syntax-object->datum
;            (syntax (body1 body2 (... ...))))))]))
;    
;    ]))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Removes the first character from a symbol
;;
;; symbol -> symbol
(define (symbol-remove-first x)
  (let ([y (symbol->string x)])  
    (string->symbol
     (substring y 1 (string-length y)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
;; Returns the first index of char in str,
;; false if it does not appear.
;;
;; str x char => int
(define (string-index str char)
  (if (not (string? str))
      (error "First argument must be a string"))
  
  (let ([index  0]
        [length (string-length str)])
    
    ;; manually expanded while loop
    (letrec ([test? (lambda ()
                      (and (< index length) 
                           (not (equal? (string-ref str index) char))))]
             
             [body  (lambda ()
                      (if (test?)
                          (begin
                            (set! index (+ index 1))
                            (body))
                          void))])
      (body))
    
    (if (= index length)
        #f
        index)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Returns a list of one or more symbols where tokens have been
;; re-broken at colons.  Called by retokenize-for-colons.
;;
;; Does not attempt to break symbols that begin with "exn:" plus one
;; character because MzScheme uses variables with colons in them for
;; exceptions.
;;
;; symbol-> (list symbol)
(define (break-symbol-at-colon sym)
  (let* ([str         (symbol->string sym)]
         [len         (string-length str)])

    (if (and (>= len 5)
             (string=? (substring str 0 4) "exn:"))

        ;; Just return the symbol; we don't try to break "exn:..."
        sym

        (let ([index       (string-index str #\:)])
          (if index
              (let ([result '(:)])
          
                (if (> index 0)
                    (set! result (cons (string->symbol (substring str 0 index)) result)))
                
                (if (< index (- len 1)) 
                    (set! result (append result (list (string->symbol (substring str (+ index 1) len))))))
                
                result)
              
              (list sym))))))

;; Finds all instances of the pattern x : y and
;; changes them to (: x y) in a new expression.
;;
;; list => list
(define (reparse-for-colons expr)
  (cond
    ;; Empty list; just return
   [(eq? expr '())              expr]
   
   ;; Last arg; just return
   [(empty? (rest expr))        expr]
    
   ;; Look ahead 1 token for a colon.  If there is one
   ;; form the nested (: var type) and recurse on the
   ;; rest of the list.
   [(eq? (second expr) ':)
    `((: ,(first expr) ,(third expr))
      ,@(reparse-for-colons (cdddr expr)))]
   
   ;; This argument does not have a type; proceed on to the
   ;; rest.
   [else (cons (first expr) (reparse-for-colons (rest expr)))]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Finds all instances of the pattern x:y and breaks them into x : y
;; in a new expression. 
;;
;; list => list
(define (retokenize-for-colons expr)
  (cond

   ;; Out of tokens, return
    [(eq? expr '())

     expr]


    ;; The first token is a symbol; see if it has a colon in it
    [(symbol? (first expr)) 

     (append (break-symbol-at-colon (first expr))
             (retokenize-for-colons
              (cdr expr)))]


    [else 

     (append (list (first expr))
             (retokenize-for-colons 
              (cdr expr)))]))


) ; end of module