#lang racket/gui

;;; file-browser.rkt - Un navigateur de modules Racket
;;; Chapitre 14 (Objets et API graphique)
;;; Livre PCPS : "Premiers Cours de Programmation avec Scheme"
;;; Langage determine par le source

(define FILE "No file")

; On recupere a la fois les noms des variables definies [au format string] et la definition [au format liste].
; Au prix d'une place en memoire, on evite ainsi de revisiter le fichier pour chaque definition.
; Ceci est possible grace au champ "data" des list-box...

(read-accept-reader #t)      ; pour lire un fichier module debutant par #lang...

(define (get-variables f)    ; f est un nom de fichier, retourne une A-liste de (string . liste)
  (call-with-input-file f
    (lambda (p-in)
      (let ((L (read p-in)) (acc '()))
        (when (not (and (pair? L) (equal? (car L) 'module)))
            (error 'get-variables "Le fichier ~s n'est pas un module Racket !" f))
        ;(printf "L --> ~s\n" L)
        (do ((L (cadddr L) (cdr L)))
          ((null? L) (reverse acc))
          (let ((e (car L)))
            (when (and (pair? e) (member (car e) '(define define-syntax)))
              (set! acc (cons (list (symbol->string (if (symbol? (cadr e)) (cadr e) (caadr e))) e) acc)))))))))

(define frame (new frame% (label FILE) (x 100) (y 50)))

(define vpanel (new vertical-panel% (parent frame)))

(define button 
  (new button% (label "Choose a file") (parent vpanel)
       (callback (lambda (b e)
                   (set! FILE (get-file "Choose a file"))
                   (let ((Lvars (get-variables FILE)))
                     (send frame set-label (format "~a : ~a definitions" FILE (number->string (length Lvars))))
                     (send list-box set '())
                     (for-each (lambda (def) (send list-box append (car def) (cadr def))) Lvars))
                   (send* text2 (lock #f) (erase) (lock #t))))))   ; une cascade de messages
                   ;(printf "FILE = ~a\n" FILE)))))

(define hpanel (new horizontal-panel% (parent vpanel)))

(pretty-print-columns 50)     ; largeur max de la ligne produite par pretty-write

(define list-box 
  (new list-box% (parent hpanel) (label #f) (choices '()) (min-width 180) 
       (stretchable-width #f)
       (callback (lambda (l e)
                   (when (eq? (send e get-event-type) 'list-box-dclick)
                       (let* ((n (car (send l get-selections))) (def (send l get-data n)))
                         (begin (send text2 lock #f)
                                (send text2 erase)
                                (send text2 change-style fixed16)
                                (let ((p-out (open-output-string)))
                                  (pretty-write def p-out)               ; mieux que pretty-print !
                                  (send text2 insert (get-output-string p-out)))
                                (send text2 lock #t))))))))

(define ecanvas2 (new editor-canvas% (label "frame2") (parent hpanel) (min-height 300) (min-width 800)))
(define text2 (new text%))
(send ecanvas2 set-editor text2)
(define fixed16 (make-object style-delta% 'change-family 'modern))   ; fixed width font
(send fixed16 set-delta 'change-size 16)
(send fixed16 set-delta 'change-bold)
(send text2 lock #t)
(send text2 hide-caret #t)

(send frame show #t)