; #lang mzscheme
(module install mzscheme
; This tile doesn't "provide" anything, but merely installs a stub file
; in the installed-teachpacks directory which invokes the real
; "tiles.ss".

 ;(require setup/dirs)
 ; (require mzlib/etc)
 ; (require scheme/file)
  (require (lib "file.ss"))
  
;  (display "Current directory is ")
;  (display (current-directory))
;  (newline)
;  (display "find-collects-dir is ")
;  (display (find-collects-dir))
;  (newline)
;  (display "this-expression-source-directory is ")
;  (display (this-expression-source-directory))
;  (newline)
;  (display "this-expression-file-name is ")
;  (display (this-expression-file-name))
;  (newline)
;  (display "addon directory, plus version, plus installed-teachpacks, is ")
;  (display (build-path (find-system-path 'addon-dir)
;                       (string->path (version))
;                       (string->path "collects")
;                       (string->path "installed-teachpacks")))
;  (define src (this-expression-source-directory))
  (define tiles-module-spec '(planet "tiles.ss" ("sbloch" "tiles.plt" 1 2)))
  
  (define destdir (build-path (find-system-path 'addon-dir)
                              (string->path (version))
                              (string->path "collects")
                              (string->path "installed-teachpacks")
                              ))
  
  (define (makefile filename module-spec)
    (let ((destfile (build-path destdir (string->path filename)))
          (require-stmt `(require ,module-spec))
          (provide-stmt `(provide (all-from ,module-spec))))
      (if (file-exists? destfile)
          (display "Teachpack file already exists.")
          (begin
            (unless (directory-exists? destdir)   
              (make-directory* destdir))
            (if (member 'write (file-or-directory-permissions destdir))
                (begin
                  (with-output-to-file destfile
                    (lambda ()
                      (begin (display "(module tiles mzscheme")
                             (newline)
                             (write require-stmt)
                             (newline)
                             (write provide-stmt)
                             (newline)
			     (display ")")
			     (newline))))
                  (display (format "Wrote file ~s to installed-teachpacks directory~n" filename)))
                (display (format "Unable to write file ~s to installed-teachpacks directory~n" filename)))
            )
          )
      )
    )
  (makefile "tiles.ss" '(planet "tiles.ss" ("sbloch" "tiles.plt" 1 2)))
;  (makefile "sb-world.ss" '(planet "sb-world.ss" ("sbloch" "sb-world.plt" 1 0)))
)