#|-------------------- 0.2.2 |# "./peep.meta" 226
;;; peep.meta -*- Hen -*-

((egg "peep.egg")
 (synopsis "Explore the compiler's symbol database")
 (needs dissector)
 (category misc)
 (license "BSD")
 (author "felix winkelmann")
 (files "peep.meta" "peep.scm" "peep.setup"))

#|-------------------- 0.2.2 |# "./peep.scm" 5303
;;;; peep.scm


#+(not csi)
(declare
  (unused .set *current-pass-no* *last-pass-flag*)
  (hide *db* *prg* 
        *name-table*
        *current-pass*
        *enabled*
        *skip-to*
        *return*
        check-prop
        it
        tty-input?) )

(use srfi-69 dissector)

(define-constant +valid-props+
  '(captured
    global
    call-sites
    home
    unknown
    assigned
    assigned-locally
    undefined
    value
    potential-value
    references
    side-effecting
    foldable
    boxed
    contractable
    inlinable
    collapsable
    removable
    replacable
    replacing
    standard-binding
    extended-binding
    unused
    rest-parameter
    o-r/access-count
    constant
    contains
    contained-in
    has-unused-parameters
    use-expr
    closure-size
    customizable
    simple
    explicit-rest
    captured-variables) )

(define *db* #f)
(define *prg* #f)
(define *name-table* (make-hash-table string=?))
(define *current-pass* #f)
(define *current-pass-no* #f)
(define *last-pass-flag* #f)
(define *enabled* #t)
(define *skip-to* #f)

(define (check-prop p)
  (if (memq p +valid-props+)
      p
      (error "invalid property" p) ) )

(define (tty-input?)
  (or (##sys#fudge 12) (##sys#tty-port? ##sys#standard-input)) )

(set! ##sys#read-prompt-hook
  (let ([old ##sys#read-prompt-hook])
    (lambda ()
      (when (tty-input?) (old)) ) ) )

(when (extension-information 'readline)
  (require 'readline)
  (unless (string=? "dumb" (getenv "TERM"))
    (current-input-port (make-gnu-readline-port))
    (gnu-history-install-file-manager
     (string-append (or (getenv "HOME") ".") "/.peep.history")) ) )

(define .get)
(define .set)
(define .q)

(user-post-analysis-pass
 (lambda (pass db prg get set no contf)
   (when (and *enabled* 
	      (or (not *skip-to*)
		  (eq? pass *skip-to*)))
     (set! *current-pass* pass)
     (set! *current-pass-no* no)
     (set! *last-pass-flag* (not contf))
     (set! .get
       (lambda (k p)
	 (get (.find k #t)
	      (check-prop p) ) ) )
     (set! .set 
       (lambda (k p x)
	 (set (.find k #t) (check-prop p) ) ) )
     (fluid-let ((*db* db)
		 (*prg* prg))
       (##sys#hash-table-for-each
	(lambda (k v)
	  (hash-table-set! *name-table* (##sys#symbol->qualified-string k) k) )
	db)
       (call/cc
	(lambda (return)
	  (set! *return* return)
	  (repl) ) ) ) ) ) )

(define (.g x y) (.get x y))

(define-record-printer (node n p)
  (display "#<node " p)
  (display (node-class n) p)
  (write-char #\> p) )

(define (.pp #!optional (n *prg*))
  (pp (if (##sys#structure? n 'node)
	  (##compiler#build-expression-tree n)
	  n) ) )

(define .p .pp)

(define (.dump)
  (##compiler#display-analysis-database *db*))

(define .d .dump)

(define (.find sym #!optional (err #f))
  (hash-table-ref
   *name-table* (->string sym) 
   (lambda ()
     (and err (error "symbol not found" sym)))))

(define .f .find)

(define (.show sym)
  (let ((props (##sys#hash-table-ref *db* (.find sym #t))))
    (if props
	(for-each
	 (lambda (p)
	   (print (car p) #\: #\tab (cdr p)) )
	 props)
	(print "no information about " sym))
    (void) ) )

(define .s .show)

(define (.select . props)
  (for-each check-prop props)
  (let ((lst '()))
    (##sys#hash-table-for-each
     (lambda (k v)
       (when (any (cut assq <> v) props)
	 (set! lst (cons k lst))))
     *db*)
    lst) )

(define .sel .select)

(define (.inspect #!optional (n *prg*)) (dissect n))

(define .i .inspect)

(define (.props)
  (for-each (cut print "  " <>) +valid-props+) )

(define (.quit)
  (set! *enabled* #f)
  (*return* #f) )

(define .q .quit)

(define (.continue #!optional pass)
  (set! *skip-to* pass)
  (*return* #f) )

(define .c .continue)

(define (.help)
  (print #<<EOF
(.pp [X])            [.p]     pretty-print node or other value (defaults to program graph)
(.dump)              [.d]     dump database
(.find NAME)         [.f]     find symbol in database
(.show SYMBOL)       [.s]     show properties of symbol
(.get SYMBOL PROP)   [.g]     get symbol property
(.set SYMBOL PROP X)          set symbol property
(.select PROP ...)   [.sel]   return list of symbols that have given properties
(.inspect [X])       [.i]     inspect value (defaults to program graph)
(.props)                      list valid symbol properties
(.quit)              [.q]     continue compilation until finished
(.continue [PASS])   [.c]     continue until PASS is reached or to next analysis
(.help)              [.h]     show this message

The special expression `#' holds the last result.

Valid PASS arguments to `.continue' are currently:

  user
  lift
  opt
  leaf
EOF
) 
 (void) )

(define .h .help)

(define it (void))

(set! ##sys#user-read-hook
  (let ([read-char read-char]
	[read read]
	[old-hook ##sys#user-read-hook] )
    (lambda (char port)
      (cond ((or (char=? #\) char) (char-whitespace? char))
	     `',it)
	    (else (old-hook char port)) ) ) ) )

(set! ##sys#repl-eval-hook
  (lambda (form)
    (let ((rs (receive (eval form))))
      (unless (null? rs) (set! it (car rs)))
      (apply values rs))))

(repl-prompt
 (lambda ()
   (sprintf "peep(~a)> " *current-pass*)))

(cond ((file-exists? ".peeprc") (load ".peeprc"))
      ((getenv "HOME") => 
       (lambda (h)
	 (cond ((file-exists? (make-pathname h ".peeprc")) => load) ) ) ) )

#|-------------------- 0.2.2 |# "./peep.setup" 91
(compile -s -O2 -d0 peep.scm)
(install-extension
 'peep
 '("peep.so")
 '((version "0.3")))