(module manuals mzscheme
  (require (lib "list.ss")
           (lib "file.ss")
           (lib "date.ss")
           (lib "string-constant.ss" "string-constants")
	   (lib "pregexp.ss")
           "colldocs.ss"
           "docpos.ss"
	   (lib "util.ss" "help" "servlets" "private")
	   (lib "remote.ss" "help" "servlets" "private"))

  ; to get CSS style spec
  (require (lib "xml.ss" "xml"))
  (require (lib "headelts.ss" "help" "servlets" "private"))  

  (provide find-manuals)
 
  (define re:title (regexp "<[tT][iI][tT][lL][eE]>(.*)</[tT][iI][tT][lL][eE]>"))

  (define remote-connections? (unbox remote-box))

  (define (find-manuals)
    (let* ([sys-type (system-type)]
	   [cvs-user? (cvs?)]
           [doc-collection-path (with-handlers ([void (lambda (x) #f)])
                                  (collection-path "doc"))]
           [docs (let loop ([l (if doc-collection-path
                                   (directory-list doc-collection-path)
                                   null)])
                   (cond
                     [(null? l) null]
                     [(file-exists? (build-path doc-collection-path (car l) "index.htm"))
                      (cons (car l) (loop (cdr l)))]
                     [else (loop (cdr l))]))]
	   [compare-docs (lambda (a b)
			   (let ([ap (standard-html-doc-position a)]
				 [bp (standard-html-doc-position b)])
			     (cond
			      [(= ap bp) (string<? a b)]
			      [else (< ap bp)])))]
           [docs (quicksort docs compare-docs)]
           [doc-paths (map (lambda (doc) (string-append "/doc/" doc "/")) docs)]
           [get-name
	    (lambda (doc-dir)
	      (let ([ass (assoc doc-dir known-docs)])
		(if ass
		    (cdr ass)
		    (with-input-from-file 
			(build-path doc-collection-path doc-dir "index.htm")
		      (lambda ()
			(let loop ()
			  (let ([r (read-line)])
			    (cond
			     [(eof-object? r) "(Unknown title)"]
			     [(regexp-match re:title r) => cadr]
			     [(regexp-match "<[tT][iI][tT][lL][eE]>(.*)$" r)
			      ;; Append lines until we find it 
			      (let aloop ([r r])
				(let ([a (read-line)])
				  (cond
				   [(eof-object? a) (loop)] ; give up
				   [else (let ([r (string-append r a)])
					   (cond
					    [(regexp-match re:title r) => cadr]
					    [else (aloop r)]))])))]
			     [else (loop)]))))))))]
	   [names (map get-name docs)]
	   [names+paths (map cons names doc-paths)]
	   [is-lang? (lambda (name+path)
		       (let ([name (car name+path)])
			 (ormap (lambda (s)
				  (regexp-match s name))
				'("Language" "MrEd"))))]
	   [lang-names+paths (filter is-lang? names+paths)]
	   [tool-names+paths (filter (lambda (x) (not (is-lang? x))) names+paths)]
	   [lang-names (map car lang-names+paths)]
	   [lang-doc-paths (map cdr lang-names+paths)]
	   [tool-names (map car tool-names+paths)]
	   [tool-doc-paths (map cdr tool-names+paths)]
	   [mk-link (lambda (doc-path name)
                      ; doc-path is of form /doc/<doc-dir>/
                      (let* ([manual-dir 
				(substring doc-path
				           5
		                           (sub1 (string-length doc-path)))]
			     [index-file (build-path 
					  (collection-path "doc")
					  manual-dir
					  "index.htm")])
                        (format "<LI> <A HREF=\"~a\">~a</A>~a"
			        doc-path
                                name
                                (if (and cvs-user?
                                         (file-exists? index-file))
                                    (string-append 
                                     "<BR>&nbsp;&nbsp;"
				     "<FONT SIZE=\"-1\">"
				     (if (or remote-connections?
					     (not (assoc manual-dir known-docs)))
					 ""
					 (string-append
					  (format 
					   "[<A HREF=\"/servlets/download-manual.ss?manual=~a&label=~a\">~a</A>]"
					   manual-dir
					   (hexify-string name)
					   (string-constant plt:hd:refresh))
					  "&nbsp;"))
				     (format (string-constant plt:hd:manual-installed-date)
                                             (date->string
                                              (seconds->date
                                               (file-or-directory-modify-seconds
                                                index-file))))
				     "</FONT>")
				    ""))))]
	   [break-between (lambda (re l)
			    (if (null? l)
				l
				(if (regexp-match re (car l))
				    (let loop ([l l])
				      (cond 
				       [(null? l) null]
				       [(regexp-match re (car l))
					(cons (car l) (loop (cdr l)))]
				       [else (cons "<P>" l)]))
				    l)))])
      (let-values ([(collections-doc-files collection-names) (colldocs)])
        (apply
	 string-append
	 "<html>"
         (xexpr->string 
	  `(HEAD
	    ,hd-css
	    ,@hd-links
	    (TITLE "PLT Manuals")))
	 "<body>"
	 (append 
	  
	  (list "<H1>Installed Manuals</H1>")
	  
	  (if (and cvs-user? (not remote-connections?))
	      (list "<b>CVS:</b> <a href=\"/servlets/refresh-manuals.ss\" target=\"_top\">"
		    (string-constant plt:hd:refresh-all-manuals)
		    "</a>")
	      '())
	  
	  (list "<H3>Languages</H3>"
		"<UL>")
	  (break-between "Student" (map mk-link lang-doc-paths lang-names))
	  (list "</UL>"
		"<H3>Tools, Libraries, and Extensions</H3>"
		"<UL>")
	  (break-between "DrScheme" (map mk-link tool-doc-paths tool-names))
	  (list "</UL><P><UL>")
	  (map
	   (lambda (collection-doc-file name)
	     (format "<LI> <A HREF=\"/servlets/doc-anchor.ss?file=~a&name=~a&caption=Documentation for the ~a collection\">~a collection</A>"
					; escape colons and other junk
		     (hexify-string
		      (build-path (car collection-doc-file) 
				  (cadr collection-doc-file)))
	             name
		     name
		     name))
	   collections-doc-files
	   collection-names)
	  (list "</UL>")
	  (let ([uninstalled (let loop ([l known-docs])
			       (cond
				[(null? l) null]
				[(member (caar l) docs) (loop (cdr l))]
				[else (cons (car l) (loop (cdr l)))]))])
	    (cond
	     [(null? uninstalled)
	      (list "")]
	     [(not doc-collection-path)
	      (list "<font color=\"red\">"
		    "Please create a doc collection."
		    "You will not be able to install any manuals until you do."
		    "</font>")]
	     [else
	      (list*
	       "<H3>Uninstalled Manuals</H3>"
	       "<UL>"
	       (append
		(map
		 (lambda (doc-pair)
		   (let ([manual (car doc-pair)]
			 [name (cdr doc-pair)])
		     (format "<LI> <A HREF=\"/servlets/missing-manual.ss?manual=~a&name=~a\">~a</A>~a"
			     manual
			     (hexify-string name)
			     name
			     (if (file-exists? 
				  (build-path doc-collection-path manual "hdindex"))
				 " (index installed)"
				 ""))))
		 uninstalled)
		(list "</UL>")))]))
	  (list "</body></html>")))))))
