#lang scheme

; TODO
; - ne générer que les fichiers obsolètes
; - make-eval-factory ... "common.ss"
; semble poser des problemes !

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

(provide package-username
         major-version
         minor-version
         package-name
         set-planet-env
         parse-module
         planet-create
         planet-build
         planet-inject
         planet-remove-package
         planet-hard-link
         planet-remove-hard-link
         delete-bak-files
         parse-module
         write-doc
         write-docs
         write-info
         write-main-doc
         write-main-src
         )

;: @(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 package.
  ;: 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)])
      (system-debug
       (string-append (path->quote-string planet-exe)
                      " create "
                      (path->quote-string package-dir)
                      )))))
  
(define (planet-inject) ;:-> void?
  ;: Launches the @filepath{planet} executable with the "file-inject" option
  ;: on the current package file in the parent directory of the $current-directory.
  ;: The package file must exist.
  (let ([package-dir (package-dir)])
    (parameterize ([current-directory (build-path (current-directory) 'up)])
      (system-debug
       (string-append (path->quote-string planet-exe)
                      " fileinject "
                      (package-username) " "
                      (path->quote-string package-dir) ".plt "
                      (number->string (major-version)) " "
                      (number->string (minor-version))
                      )))))
  
(define (planet-remove-package) ;:-> void?
  ;: Calls $remove-pkg on the current package environment settings.
  (remove-pkg (package-username) 
              (string-append (package-name) ".plt")
              (major-version) (minor-version)))

; - 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 (this-package-in-string [file #f]) ;:-> string?
  ;: Returns a string that can be used to compose with the sting
  ;: "(require (planet " ....
  (let*-values ([(user pack-file maj min) (apply values (this-package-version))]
                [(pack ext) (file->name-ext pack-file)])
    (string-append user "/" pack ":" (number->string maj) 
                   ":" (number->string min)
                   (if file
                       (string-append "/" file)
                       ""))))
         
(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) and adding header information.
  (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
      (string-append 
       "#lang scribble/manual
@(require (planet cce/scheme:6:0/scribble)
          scribble/eval
          (for-label scheme
                     (this-package-in " filename ")))

@(define make-my-eval (make-eval-factory '(scheme 
            (planet " (this-package-in-string filename) "))))

"
  (scrbl-parse-file filename extension prov)))))
;          \"eval.ss\"
;@(define make-my-eval (make-eval-factory '(scheme
;            (planet " (this-package-in-string filename) "))))

;[: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
    (λ()(display 
         "#lang scheme/base
(require (planet cce/scheme:6:0/require-provide)
         scheme/require-syntax)

(require/provide 
")
      (for-each (λ(f)(printf " \"~a\"~n"  f))
                files)
      (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"))
      (λ()(display
           (string-append
            "#lang scribble/manual
@(require (planet cce/scheme:6:0/scribble)
          (for-label scheme))

@title{Package " (package-name) "}
@(defmodule/this-package)

@author{" (package-username) "}

@table-of-contents[]
"))
        (for-each (λ(f)(printf "@include-section[\"~a\"]~n"
                               (regexp-replace "\\.ss$" f ".scrbl"))) 
                  files))
      #: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{info.ss} 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 "infos.ss")])
    (with-output-to-file "info.ss"
      (λ()(display
           (string-append
            "#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 "main.ss"] ;: (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 "info.ss") except)
                  (map to-string (filter-file-list "(?:\\.ss|\\.scm)$")))])
  ; Write main.ss:
  (when main-src 
    (printf "Writing main source file: ~a...~n" main-src)
    (write-main-src main-src files))
  ; Write info.ss:
  (when info? 
    (printf "Writing info.ss...~n")
    (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:
  (for-each 
   (λ(f)
     (printf "Writing documentation file: ~a...~n" f)
     (write-doc f dir #:exists 'replace))
   files)
  ))

(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 [username (package-username)]   ;: string?
                      [major (major-version)]         ;: number?
                      [minor (minor-version)]         ;: number?
                      #:dir [dir "reference"]         ;: path-string?
                      #:main-src [main-src "main.ss"] ;: (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.
  ;:
  (parameterize ([package-username username]
                 [major-version major]
                 [minor-version minor])
    (planet-hard-link)
    (write-docs #:dir dir #:main-src main-src #:main-doc main-doc 
                #:info? info? #:except except)
    (delete-bak-files)
    (planet-create)
    ))

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