#! /usr/bin/env scheme-chicken
;;;; formatprofile - Script for formatted display of profile outputs - felix -*- Scheme -*-


(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-avg              Sort output by average procedure execution time
  -sort-by-name             Sort output alphabetically by procedure name
  -no-unused                Remove procedures that are never called
  -help                     Show this text

  FILENAME defaults to "PROFILE"

EOF
) 
  (exit 64) )

(define (run args)
  (let loop ([args args])
    (if (null? args)
	(begin
	  (unless file (set! file "PROFILE"))
	  (write-profile) )
	(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-avg" (set! sort-by sort-by-avg)] 
	    ["-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-avg x y)
  (let ([c1 (cadddr x)]
	[c2 (cadddr y)] )
    (if (= c1 c2)
	(> (third x) (third 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 (map
                     (lambda (t) (append t (let ((c (second t))
                                                 (t (third t)))
                                             (list (or (and (> c 0) (/ t c))
                                                       0)))))
                     (with-input-from-file file read-file)) sort-by)]
	[line (make-string (+ 48 8 8 8 4) #\-)] )
    (format #t " ~48A ~8@A ~8@A ~8@A~%" "procedure" "calls" "seconds" "average")
    (print line)
    (for-each
     (lambda (entry)
       (let ([c (second entry)]
	     [t (third entry)]
             [a (cadddr entry)] )
	 (unless (and (zero? c) no-unused)
	   (format #t " ~48A ~8D ~8,3F ~8,3F~%" (##sys#symbol->qualified-string (first entry)) c (/ t 1000) (/ a 1000)) ) ) )
     data) ) )

(define (main args)
  (run (cdr args)) )

