#! /usr/bin/csi -script
;;;; formatprofile - Script for formatted display of profile outputs - felix


(declare (uses extras format match srfi-1))


(define sort-by #f)
(define file #f)
(define no-unused #f)

(define (print-usage)
  (display #<<EOF
Usage: formatprofile [FILENAME | OPTION] ...

  -sort-by-calls            Sort output by call frequency
  -sort-by-time             Sort output by procedure execution time
  -sort-by-name             Sort output alphabetically by procedure name
  -no-unused                Remove procedures that are never called
  -help                     Show this text

EOF
) 
  (exit 64) )

(define (run args)
  (let loop ([args args])
    (if (null? args)
	(if file
	    (write-profile)
	    (print-usage) )
	(let ([arg (car args)]
	      [rest (cdr args)] )
	  (match arg
	    ["-help" (print-usage)]
	    ["-no-unused" (set! no-unused #t)]
	    ["-sort-by-calls" (set! sort-by sort-by-calls)]
	    ["-sort-by-time" (set! sort-by sort-by-time)] 
	    ["-sort-by-name" (set! sort-by sort-by-name)]
	    [_ (cond [(and (> (string-length arg) 1) (char=? #\- (string-ref arg 0)))
		      (error "invalid option" arg) ]
		     [file (print-usage)]
		     [else (set! file arg)] ) ] )
	  (loop rest) ) ) ) )

(define (sort-by-calls x y)
  (let ([c1 (second x)]
	[c2 (second y)] )
    (if (= c1 c2)
	(> (third x) (third y))
	(> c1 c2) ) ) )

(define (sort-by-time x y)
  (let ([c1 (third x)]
	[c2 (third y)] )
    (if (= c1 c2)
	(> (second x) (second y))
	(> c1 c2) ) ) )

(define (sort-by-name x y)
  (string<? (symbol->string (first x)) (symbol->string (first y))) )

(set! sort-by sort-by-time)

(define (write-profile)
  (let ([data (sort (with-input-from-file file read-file) sort-by)]
	[line (make-string (+ 48 8 8 4) #\-)] )
    (format #t " ~48A ~8@A ~8@A~%" "procedure" "calls" "seconds")
    (print line)
    (for-each
     (lambda (entry)
       (let ([c (second entry)]
	     [t (third entry)] )
	 (unless (and (zero? c) no-unused)
	   (format #t " ~48A ~8D ~8,3F~%" (##sys#symbol->qualified-string (first entry)) c (/ t 1000)) ) ) )
     data) ) )

(run (command-line-arguments))
