#lang scheme

(require scheme/system
;         (planet cce/scheme:6:0/scribble)
;         (this-package-in common)
;         (this-package-in defs-parser)

(provide package-username

;: @(require (this-package-in package)
;:           (for-label (planet cce/scheme:6:0/scribble)))

;: @(define scrbl @filepath{.scrbl})

;[:title Package Utilities]
;: This module provides definitions to easily create PLaneT packages
;: along with their documentation (using the automatic scribble parser,
;: see @secref{defs-parser}).
;: All the functions of this module are meant to be used
;: when @scheme[current-directory] is correctly set to the
;: directory of your package. This is generally true when evaluating
;: a file of your package in DrScheme.

;(make-planet-archive (current-directory))

; Contains the name of the package if this file is at the root
; and the current directory is correct...
(define package-name (make-parameter 
                      (let-values ([(p name r) (split-path (current-directory))]) 
                        (path->string name))) ;:-> string?
  ;[:arg-id name]
  ;: A parameter controlling the name of the patckage.
  ;: By default it is the name of the current directory.
(define major-version (make-parameter 1) ;:-> number?
  ;[:arg-id number]
  ;: A parameter controlling the major-version number of the current package (default: 1).
(define minor-version (make-parameter 0) ;:-> number?
  ;[:arg-id number]
  ;: A parameter controlling the minor-version number of the current package (default: 0).
(define package-username (make-parameter (getenv "username")) ;:-> string?
  ;[:arg-id username]
  ;: A parameter controlling the username number of the current package
  ;: By default it is the username of the OS environment.

(define (set-planet-env username major minor [name (package-name)]) ;:-> void?
  ;: [username string?]
  ;: [major number?]
  ;: [minor number?]
  ;: Creates a environment suitable for calling the functions of this module,
  ;: by setting the $package-username, $major-version, $minor-version and
  ;: $package-name parameters to the given values.
  ;: Call this function before any other if you want to change the default values
  ;: of the parameters.
  [package-username username]
  [major-version major]
  [minor-version minor]
  [package-name name])

; remove trailing "\\"
(define (package-dir)
  (let([d (path->string (current-directory))])
    (substring d 0 (- (string-length d) 1))))
;  (current-directory))

(define exec-dir (find-system-path 'orig-dir))
;  (let-values ([(base name must-be-dir?) (split-path (find-system-path 'run-file))])
;    base))

(define planet-exe
  (build-path exec-dir "planet"))

(define (system-debug str)
  (printf "System: ~a~n" str)
  (system str))

(define (planet-create) ;:-> void?
  ;: Launches the @filepath{planet} executable with the "create" option.
  ;: The package file is put in the parent directory of the package.
  ;: Using the planet executable seems to provide more debug info than
  ;: $make-planet-archive.
  (let ([package-dir (package-dir)])
    (parameterize ([current-directory (build-path (current-directory) 'up)])
       (string-append (path->quote-string planet-exe)
                      " create "
                      (path->quote-string package-dir))))))
; - package-clean
; supprimer tous les fichiers .bak, etc.
; - vérifier si le .scrbl est plus récent que le .ss ?
; si oui, ne pas le modifier !

; Pour que this-package-in fonctionne,
; il faut dire à planet qu'on est un package !

(define ns (make-base-namespace))
(eval '(require (planet cce/scheme:6:0/require-provide)) ns)

(define (parse-module package-name filename [extension "ss"]) ;:-> string?
  ;: [package-name string?]
  ;: [filename string?]
  ;: [extension string?]
  ;: Creates the whole scribble string associated
  ;: with $filename, automatically looking for the provided definitions
  ;: (using $quote-require).
  (let* ( [file (string-append filename "." extension)]
          [req-file (path->string (build-path (current-directory) file))]
          [prov (eval `(quote-require (file ,req-file)) ns)]
          ; because current-directory may not be the one used for quote-require (strange !)
    (parameterize ([conventions (conventions)])
;      (printf "Provides: ~a~n" (provided))
      ; quote-require cannot be used at a non top-level
       "#lang scribble/manual
@(require (planet cce/scheme:6:0/scribble)
          (for-label scheme
                     (this-package-in " filename ")))

@(defmodule/this-package " filename ")

@(define make-my-eval (make-eval-factory '(scheme \"" file "\")))

  (scrbl-parse-file filename extension prov)))))

;[:convention exists (or/c 'error 'append 'update 'replace 'truncate 'truncate/replace)]
;[:convention dir (or/c path-string? 'up 'same)]
;[:convention files (listof path-string?)]

(define (write-doc file [dir 'same] #:exists [exists 'error]) ;:-> void?
  ;: [file string?]
  ;: Writes the @scrbl file associated with $file in the directory $dir.
  ;: The $exists argument is the same as for $with-output-to-file, and
  ;: the $dir argument is the same as for $build-path.
  (let-values ([(filename ext) (file->name-ext file)])
    (with-output-to-file (build-path dir (string-append filename ".scrbl"))
      (λ()(display (parse-module (package-name) filename ext)))
      #:exists exists

(define (write-main-src main files #:exists [exists 'replace]) ;:-> void?
  ;: [main path-string?]
  ;: (Re)writes the main source file of the package, using $require-provide
  ;: for each file of the package.
  (with-output-to-file main
         "#lang scheme/base
(require (planet cce/scheme:6:0/require-provide)

      (for-each (λ(f)(printf " \"~a\"~n"  f))
      (display " )\n")
    #:exists exists))

(define (exn-warning-exists f)
  (λ(e)(printf "*** WARNING: ~a already exists. You need to remove it yourself if you want it to be rewritten.~n" f)))

(define (write-main-doc main dir files #:exists [exists 'error]) ;:-> void?
  ;: [main path-string?]
  ;: Writes the main @scrbl file in the $dir directory with a table of contents.
  ;: If $exists is @scheme['error], $write-main-doc only displays 
  ;: a warning and does not overwrite the file.
  ;: If modules have been added to the package since the last
  ;: execution of @scheme[(planet-build)],
  ;: either the user should delete the $main file so that it will be rewritten,
  ;: or the user should add the inclusion of the modules himself in the
  ;: $main file.
  (with-handlers ([exn:fail:filesystem? (exn-warning-exists main)])
    (with-output-to-file (build-path dir (string-append main ".scrbl"))
            "#lang scribble/manual
@(require (planet cce/scheme:6:0/scribble)
          (for-label scheme))


@title{Package " (package-name) "}

@author{" (package-username) "}

        (for-each (λ(f)(printf "@include-section[\"~a\"]~n"
                               (regexp-replace "\\.ss$" f ".scrbl"))) 
      #:exists exists)))

(define (write-info dir main-src main-doc #:exists [exists 'error]) ;:-> void?
  ;: [main-src string?]
  ;: [main-doc string?]
  ;: Writes a stub of the the @filepath{} file that ought to be modified
  ;: by the user.
  ;: The argument $dir is the sub-directory of the documentation.
  ;: See $write-main-doc for information about the $exists option.
  (with-handlers ([exn:fail:filesystem? (exn-warning-exists "")])
    (with-output-to-file ""
            "#lang setup/infotab

(define name \"" (package-name) "\")
(define blurb '(\"This is package " (package-name) "\"))
(define release-notes '(\"Initial release\"))
(define primary-file \"" main-src "\")
(define categories '(misc))
(define scribblings '((\"" dir "/" main-doc ".scrbl\" (multi-page))))
(define repositories '(\"4.x\"))")))
      #:exists exists)))
(define (write-docs #:dir [dir "reference"]         ;: path-string?
                    #:main-src [main-src ""] ;: (or/c #f string?)
                    #:main-doc [main-doc "manual"]  ;: (or/c #f string?)
                    #:info? [info? #t]              ;: boolean?
                    #:except [except '()]           ;: (listof string?)
                    )                               ;:-> void?
  ;: Calls $write-main-src on $main-src, $write-main-doc on $main-doc,
  ;: if they are provided.
  ;: Calls $write-info if $info? is $#t, and creates the documentation
  ;: directory $dir if it does not already exist.
  ;: (Re)writes the @scrbl file for all other @filepath{.ss} or @filepath{.scm} file
  ;: in the directory (but not in sub-directories), without warning.
  ;: An exception list of files that must not be included
  ;: in the process can be given through $except.
  (let ([files
         (remove* (append (list main-src "") except)
                  (map to-string (filter-file-list "(?:\\.ss|\\.scm)$")))])
  ; Write
  (when main-src 
    (printf "Writing main source file: ~a...~n" main-src)
    (write-main-src main-src files))
  ; Write
  (when info? 
    (printf "Writing")
    (write-info dir main-src main-doc))
  ; Create documentation directory:
  (unless (directory-exists? dir)
    (printf "Creating documentation directory: ~a...~n" dir)
    (make-directory dir))
  ; Write manual scrbl file:
  (when main-doc 
    (printf "Writing main documentation file: ~a.scrbl...~n" main-doc)
    (write-main-doc main-doc dir files))
  ; Write doc files:
     (printf "Writing documentation file: ~a...~n" f)
     (write-doc f dir #:exists 'replace))

(define (delete-bak-files) ;:-> void?
  ;: Deletes all @filepath{.bak} files, in the current directory and
  ;: its sub-directories, that may have been created by DrScheme.
  (for-each delete-file 
            (filter-file-list "\\.bak$" (directory-list-rec))))

(define (planet-hard-link) ;:-> void?
  ;: Creates a @PLaneT hard link to the current directory
  ;: so that it is considered as a package.
  (add-hard-link (package-username)
                 (string-append (package-name) ".plt")
                 (major-version) (minor-version) (current-directory)))

(define (planet-remove-hard-link) ;:-> void?
  ;: Removes the planet hard link of the current package.
  (remove-hard-link (package-username)
                    (string-append (package-name) ".plt")
                    (major-version) (minor-version)))

(define (planet-build  #:dir [dir "reference"]         ;: path-string?
                       #:main-src [main-src ""] ;: (or/c #f string?)
                       #:main-doc [main-doc "manual"]  ;: (or/c #f string?)
                       #:info? [info? #t]              ;: boolean?
                       #:except [except '()]           ;: (listof string?)
                       )                               ;:-> void?
  ;: [except (listof string?)]
  ;: Creates a hard-link,
  ;: calls $write-docs with the $except exception list of files,
  ;: calls $delete-bak-files, and then calls $planet-create.
  ;: See $write-docs for the description of the keyword options.
  (write-docs #:dir dir #:main-src main-src #:main-doc main-doc 
              #:info? info? #:except except)

;(define (package-send)
;  (planet-remove-hard-link)
;  ...
;  )