#lang scheme

;; ##################################################################################
;; # ============================================================================== #
;; # code-generation.ss                                                             #
;; # http://mred-designer.origo.ethz.ch                                             #
;; # Copyright (C) Laurent Orseau, 2010                                             #
;; # ============================================================================== #
;; #                                                                                #
;; # This program is free software; you can redistribute it and/or                  #
;; # modify it under the terms of the GNU General Public License                    #
;; # as published by the Free Software Foundation; either version 2                 #
;; # of the License, or (at your option) any later version.                         #
;; #                                                                                #
;; # This program is distributed in the hope that it will be useful,                #
;; # but WITHOUT ANY WARRANTY; without even the implied warranty of                 #
;; # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the                  #
;; # GNU General Public License for more details.                                   #
;; #                                                                                #
;; # You should have received a copy of the GNU General Public License              #
;; # along with this program; if not, write to the Free Software                    #
;; # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.    #
;; #                                                                                #
;; ##################################################################################


(require "mred-id.ss"
         "code-write.ss"
         "mreddesigner-misc.ss"
         scheme/gui/base)

;; List of other things to write in the file before the init function
(define precode-list '())
(define (add-precode e)
  (set! precode-list (cons e precode-list)))

(provide precode)
(define-syntax-rule (precode arg ...)
  (add-precode (cons '(arg ...) precode-list)))

;; Use this form to define a function that should be added
;; in the generated file.
(provide define/precode)
(define-syntax-rule (define/precode (name arg ...) body ...)
  (begin
    (define (name arg ...) body ...)
    (add-precode '(define (name arg ...) body ...))
    ))
                      
(define (print-precode)
  (for-each (λ(e)(pretty-print e) (newline))
            (reverse precode-list)))
  


; ******************************************************
; * Code generation for exporting to files and console *
; ******************************************************

(define (module-header)
  (string-append "\
#lang scheme/gui

;;==========================================================================
;;===                Code generated with MrEd Designer " application-version
                                                         "               ===
;;===                 http://mred-designer.origo.ethz.ch                 ===
;;==========================================================================

") ; add the name of the project and the date ? and the username ?
  )
 
(define (print-requires reqs)
  (display "(require\n")
  (for-each (λ(r)(printf " ~a\n" r))
            reqs)
  (display " )\n\n")
  )

;; Takes a list of top-level-windows and
;; generates the corresponding module.
;; tlw-list: list of top-level-window mred-id<%> widgets
(define/provide (generate-module mid [out (current-output-port)])
  (parameterize ([current-output-port out])
    ; TODO: add the files `require'd, as defined in the project properties.
    (let* ([project-name (send mid get-id)]
           [children (send mid get-mred-children)]
           ; save original parents:
           [children-parents (map-send get-mred-parent children)]         
           ; remove parents (i.e., the project-mid, which we don't want to be in the code):
           [_ (for-each-send (set-mred-parent #f) children)]
           [all-mred-ids (append-map get-all-children children)]
           ;[all-mred-ids (get-all-children mid)]
           ; the order of the widgets is correct for the following.
           [all-ids (map (λ(w)(send w get-id)) all-mred-ids)]
           [provides (cons 'provide 
                           ; provide only ids that are checked
                           (append-map (λ(mid)(if (send (send mid get-property 'id) get-option)
                                                  (list (send mid get-id))
                                                  '()))
                                       all-mred-ids))]
;                           all-ids)]
           [all-defines (map (λ(id)(list 'define id #f))
                             all-ids)]
           [all-options (append-map (λ(m)(send m generate-options))
                                    all-mred-ids)]
           [all-setters (map (λ(m)(send m generate-code)) 
                             all-mred-ids)]
           [shows (map (λ(tlw)(list 'send (send tlw get-id) 'show #t))
                       (filter (λ(m)(is-a? (send m get-widget) top-level-window<%>))
                               all-mred-ids))]
           [init-name (symbol-append* project-name "-init")]
           [requires (send mid get-property-value 'code-requires)]
           [arguments all-options]
           )
      (display (module-header))
      (printf ";;; Call (~a) with optional arguments to this module\n\n" init-name)
      (print-requires requires)
      (pretty-print provides)
      (newline)
      (print-precode)
      (for-each pretty-print all-defines)
      (pretty-print
       (append
        `(define ,(cons init-name arguments))
        all-setters
        shows
        ))
      
      ; restore original parents:
      (for-each (λ(c cp)(send c set-mred-parent cp))
                children
                children-parents)
      )))

; Callbacks and classes must be arguments of the initialization function.
; Could we add arbitrary parameters?
; dependant on the widget, and is a default value property ?

    

; ****************************************************
; * Code generation for saving projects and patterns *
; ****************************************************

;; Generates the save-code (e.g., to save projects, not the user-code)
;; corresponding to the descending hierarchy
(define/provide (write-mred-id-code mid)
  (let* ([save-parent (send mid get-mred-parent)]
         [parent-sym (gensym 'parent-)]
         [stub-parent (make-code-write-stub parent-sym)])
    ; replace the actual parent with a stub parent
    ; to avoid to get all the above hierarchy
    ; When code-written, it will write the parent-sym symbol instead.
    (send mid set-mred-parent stub-parent) 
    (let-values ([(code dico) (code-write-value (get-all-children mid) #t)])
      (begin0 
        ; return value:
        ; the value is a function that takes the parent of mid:
        (list 'lambda (list parent-sym);(list (first (dict-ref dico stub-parent)))
               code)
        ; restore parent:
        (send mid set-mred-parent save-parent)
        ))))
      


;; OBSOLETE (see template.ss/save-template)
;; Saves a mred-id% with all its children into a file
;(define/provide (save-mred-id mid file)
;  (let ([code (write-mred-id-code mid)])
;    ; compute the code beforehand in case there are some printings on the output
;    (with-output-to-file file
;      (λ()
;        (display
;         (string-append "; This file was generated with "
;                        application-name-version "\n\n"))
;        (pretty-print code))
;      #:exists 'replace)))