Clements

clements.rkt

#lang racket

(require json
         rackunit)

(define path-to-shell "/Users/clements/jsshell-mac/js")
(define path-to-target-file "/tmp/foo")

;; convert a JS string to a list of varrefs
(define (str->varrefs str) 
  (parsed->varrefs (string->parsed str)))

;; convert a path containing a js file to a list of varrefs.
(define (path->varrefs path)
  (parsed->varrefs (path->parsed path)))

;; convert a string to a parsed json representation (uses js shell)
(define (string->parsed str)
  (display-to-file str path-to-target-file #:exists 'truncate)
  (path->parsed path-to-target-file))

;; given a file path, parse it into a jsexpr (uses js shell)
(define (path->parsed path)
  (define js-parse-exp
    (string-append "print(JSON.stringify(Reflect.parse(read(\""
                   path
                   "\"),{loc : false})));"))
  (match-define (list i o pid stderr command-thunk)
    (process* path-to-shell "-e" js-parse-exp))
  (close-output-port o)
  (define obj (read-json i))
  (command-thunk 'wait)
  (regexp-match #px"[[:space:]]*" i)
  (match (read-byte i)
    [(? eof-object? _) obj]
    [other 
     (error "more non-whitespace bytes left after json object read: ~e" 
            other)]))

;; given a jsexpr, produce a list of its varrefs.
(define (parsed->varrefs parsed)
  (remove-duplicates ((collect varref-collector varref-subtrees) parsed)))

;; append together the result of calling the 
;; matcher on every node of the tree
(define ((collect matches subtrees) tree)
  (define this-matches (matches tree))
  ;; the ones to recur on. !@#$ JS parser.
  (define recur-on (subtrees tree))
  (define sub-matches
    (map (collect matches subtrees)
    (cond [(list? recur-on) recur-on]
          [(hash? tree)     (hash-values recur-on)]
          [else             empty])))
  (append this-matches (apply append sub-matches)))

;; return lists of varrefs when they occur:
(define (varref-collector tree)
  (match tree
    [(hash-table ('type "Identifier") ('name n) ('loc _))
     (list (string->symbol n))]
    [other empty]))

;; return the things to recur on.
;; this only exists because spidermonkey's dumb parser
;; doesn't distinguish varrefs from other identifiers.
(define (varref-subtrees tree)
  ;; omitting things without 'type fences out 
  ;; locations and the JSON.stringify representation
  ;; of regexps, which is apparently {} ...
  (cond [(and (hash? tree) (hash-has-key? tree 'type))
         (match (hash-ref tree 'type)
           ;; special cases:
           ["ObjectExpression"
            (for/list ([prop (hash-ref tree 'properties)])
              (hash-ref prop 'value))]
           ["ObjectPattern"
            (for/list ([prop (hash-ref tree 'properties)])
              (hash-ref prop 'value))]
           ["MemberExpression"
            (cond [(equal? (hash-ref tree 'computed) #t) tree]
                  [else (list (hash-ref tree 'object))])]
           ["XMLQualifiedIdentifier"
            (cond [(equal? (hash-ref tree 'computed) #t) tree]
                  [else (list (hash-ref tree 'left))])]
           ;; semi-special cases from table below:
           [ty
            (match (assoc (string->symbol ty) subsearch)
              [(list-rest _ rest)
               (for/list ([key rest])
                 (hash-ref tree key))]
              [#f (hash-values tree)])])]
        [else tree]))

;; for these types, only search the fields named:
(define subsearch 
  '((FunctionDeclaration body)
    (LabeledStatement body)
    (BreakStatement)
    (ContinueStatement)
    (FunctionExpression body)
    (ObjectPattern)
    (CatchClause body) ;; guard is spidermonkey only
    ;; (VariableDeclarator init) -- taking this one out.
    ))
    ;; XMLFunctionQualifiedIdentifier -- spidermonkey only
    ;; LetStatement -- spidermonkey only
    ;; LetExpression -- spidermonkey only
    ;; ComprehensionBlock -- spidermonkey only


;(string->parsed "obj.f")
;(string->parsed "obj[f]")
;(string->parsed "var [a,b,c] = 13 + j;")

;; TEST CASES:


(check-equal? (str->varrefs "13") '())
(check-equal? (str->varrefs "x") '(x))
(check-equal? (str->varrefs "function q(z){return 5+z+z;}") '(z))
(check-equal? (str->varrefs "function q(z){zabba: return 5+z+z;}") '(z))
(check-equal? (str->varrefs "function q(z){flork: while(1){continue flork;}}") '())
(check-equal? (str->varrefs "function q(z){flork: while(1){break flork;}}") '())
(check-equal? (list->set
               (str->varrefs "var g = function f(z){return h+h;}"))
              (set 'h 'g))
(check-equal? (list->set (str->varrefs "var {a : n, b: m} = 13 + j;")) 
              (set 'j 'n 'm))
(check-equal? (list->set (str->varrefs "var [a,b,c] = 13 + q;")) 
              (set 'q 'a 'b 'c))
(check-equal? (str->varrefs "try {3;} catch(z){y000;}") '(y000))
(check-equal? (list->set (str->varrefs "var c = {a : 13, b : z + 4};")) 
              (set 'z 'c))
(check-equal? (list->set (str->varrefs "f(x)")) (set 'f 'x))
(check-equal? (list->set (str->varrefs "f[x]")) (set 'f 'x))
(check-equal? (list->set (str->varrefs "f.x")) (set 'f))
(check-equal? (list->set (str->varrefs "var x = z::a;")) (set 'z 'x))
(check-equal? (list->set (str->varrefs "var x = z::[a];"))
              (set 'z 'a 'x))

#;(string->parsed "/ab+c/i;")
(path->varrefs "/tmp/jquery/test/unit/ajax.js")
#;(remove*
 (sort (path->varrefs "/tmp/foo.js" #;"/tmp/jquery/test/unit/ajax.js")
       string<?
       #:key symbol->string)
 
 '(a b c d f g h j undefined l m print n o p q r s t x z))

#;(display-to-file (path->parsed "/tmp/jquery/test/unit/ajax.js")
                 "/tmp/aoeu.rktd"
                 #:exists 'truncate)