;;;; expand-full.scm
;;;; Kon Lovett, Apr '09

;;;

(module expand-full

(;export
  expand*
  pretty-print-expand* ppexpand*)

(import
  scheme
  (chicken base)
  (chicken type)
  (chicken syntax)
  (only (chicken platform) feature?)
  (only (chicken csi) toplevel-command)
  (only (chicken pretty-print) pretty-print)
  (only (srfi 1) proper-list? map!)
  (only vector-lib vector-map))

;;

(: expand (* #!optional * --> *))
;
(define (expand* form #!optional se)
  (let expand-loop ((form form))
    (let (
      (expanded
        (cond
          ((null? form)
            '() )
          ((proper-list? form)
            (let ((expanded (expand form se)))
              (if (not (proper-list? expanded))
                expanded
                (map! expand-loop expanded) ) ) )
          ((pair? form)
            (cons (expand-loop (car form)) (expand-loop (cdr form))) )
          ((vector? form)
            (vector-map (lambda (_ x) (expand-loop x)) form) )
          (else
            form ) ) ) )
      (if (equal? form expanded)
        form
        (expand-loop expanded) ) ) ) )

#; ;WTF
(define (expand* form #!optional se going-up?)
  ;
  (: protected? (* --> boolean))
  ;
  (define (protected? obj)
    (or (null? obj) (atom? obj) (not (proper-list? obj))) )

  (: protected-expand (* #!optional * --> *))
  ;
  (define (protected-expand form #!optional se)
    (if (protected? form)
      form
      (expand form se)) )

  (: protected-equal=? (* * --> boolean))
  ;
  (define (protected-equal=? a b)
    (or
      (and (not (number? a)) (protected? a))
      (and (not (number? b)) (protected? b))
      (equal=? a b)) )
  ;
  (let expand*-loop ((form form))
    ;
    (define (seq-expand form)
      (cond
        ((pair? form)
          (cons (expand*-loop (car form)) (expand*-loop (cdr form))) )
        ((list? form)
          (map expand*-loop form) )
        ((vector? form)
          (vector-map (lambda (_ x) (expand*-loop x)) form) )
        (else
          form ) ) )
    ;
    ;(define local-protected-expand (o strip-syntax (cut protected-expand <> se)))
    (define local-protected-expand (cut protected-expand <> se))
    ;
    (define bottom-up (o local-protected-expand seq-expand))
    (define top-down (o seq-expand local-protected-expand))
    (define go-direction (if going-up? bottom-up top-down))
    ;
    (let ((expanded (go-direction form)))
      (if (protected-equal=? form expanded)
        form
        (expand*-loop expanded) ) ) ) )

;;

(: pretty-print-expand* (* #!optional * --> *))
;
(define (pretty-print-expand* form #!optional se)
  (pretty-print (strip-syntax (expand* form se)))
  (void) )

(: ppexpand* (* #!optional * --> *))
;
(define ppexpand* pretty-print-expand*)

;;;

(when (feature? 'csi)
  (toplevel-command 'x*
    ;FIXME need apropos like csi argument handler
    (lambda () (ppexpand* (read)))
    ",x* EXP           Pretty print, almost fully, expanded expression EXP") )

) ;module expand-full