Download code

Jump to: navigation, search

Back to OCAMAWEB/Sources

Download for Windows: single file, zip

Download for UNIX: single file, zip, tar.gz, tar.bz2

ocamaweb.ml

   1 (* The authors of this work have released all rights to it and placed it
   2 in the public domain under the Creative Commons CC0 1.0 waiver
   3 (http://creativecommons.org/publicdomain/zero/1.0/).
   4 
   5 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
   6 EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
   7 MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
   8 IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
   9 CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  10 TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  11 SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  12 
  13 Retrieved from: http://en.literateprograms.org/OCAMAWEB/Sources?oldid=3468
  14 *)
  15 
  16 
  17 let version = "6.0";;
  18 
  19 open Str;;
  20 open Xml;;
  21 
  22 (*<
  23   \section{Fonction globales et définitions}
  24 
  25   La variable d'environnement {\sf OCAMAWEB} est utilisée comme
  26   chemin pour le fichier de log (son nom est \code{"ocamaweb.log"})
  27   et pour le fichier {\tt ocamaweb.sty}.
  28   
  29 
  30   La variable d'environnement {\sf OCAMAWEB\_DEST} est utilisée comme
  31   repository de fichiers de doc.
  32 
  33   Attention: j'ai besoin du slash de fin!
  34 
  35 *)
  36 
  37 let log_file = 
  38   try
  39     open_out ((Sys.getenv "OCAMAWEB") ^ "ocamaweb.log")
  40   with Not_found -> 
  41     Printf.fprintf stderr "OCAMAWEB: WARNING! WARNING! WARNING!\n          environment variable 'OCAMAWEB' not defined!\n";
  42     open_out "ocamaweb.log"
  43 ;;
  44 
  45 (* to be used as output for undefined special keys *)
  46 let not_defined = "***NOT DEFINED***";;
  47 
  48 let root_string = "***ROOT***";;
  49 
  50 let empty_string = "***EMPTY***";;
  51 
  52 let relations     = Hashtbl.create 20;;
  53 
  54 let sub_relations = Hashtbl.create 20;;
  55 
  56 (*< 
  57   \subsection{parsing d'une ligne}
  58   Lors du parcours du fichier de CODE, chaque ligne va se voir attribuer un type [state].\\
  59   Les différents éléments de ce type sont :
  60   \begin{itemize}
  61 
  62   \item \code{Into_comments} : il s'agit d'une ligne de commentaire "classique"
  63   (elle fera partie soit du code soit des commentaires du bloc suivant sa position
  64   relative p/r aux autres lignes)
  65 
  66   \item \code{Begin_section} : il s'agit de la déclaration d'une section (par %%)
  67   (de cette ligne on va tirer le titre -d'où la référence sera déduite- et le début
  68   des commentaires de bloc)
  69 
  70   \item \code{Begin_subsection} : il s'agit d'une section incluse (par %<)
  71   (de cette ligne on va tirer le titre -d'où la référence sera déduite- et le début
  72   des commentaires de bloc)
  73 
  74   \item \code{End_subsection} : il s'agit d'une ligne de code
  75 
  76   \item \code{Begin_file} : c'est l'état en début de fichier
  77 
  78   \item \code{Unknown}    : c'est un état piégeant destiné aux erreurs
  79   \end{itemize}
  80 *)
  81 
  82 type state = Into_comments | Begin_section | Begin_subsection | 
  83   End_subsection | Into_code | Begin_file | Unknown;;
  84 
  85 type action = Add_comment | Add_code | Add_comments_into_code | New_section | 
  86   New_subsection | Into_first_section | Close_subsection | Stop;;
  87 
  88 (* used to attribute a level to sections *)
  89 type state_level = Not_relevant | Star | Double_star | Level of string;;
  90 
  91 (* j'ai le titre X le nombre d'espaces X un code de référence (numéro d'ordre) *)
  92 type indented_ref = Indented_ref of string * int * int;;
  93 
  94 (* quelques utilitaires pour clarifier le code *)
  95 let next1 s   = 
  96   try
  97     (String.sub s 1 ((String.length s) - 1))
  98   with Invalid_argument( ia_s) -> Printf.fprintf log_file "next1: String.sub problem on %s\n" s;
  99     (* flush log_file; *)
 100     ""
 101 ;;
 102 
 103 let next2 s   = 
 104   try
 105     (String.sub s 2 ((String.length s) - 2))
 106   with Invalid_argument( ia_s) -> Printf.fprintf log_file "next2: String.sub problem on %s\n" s;
 107     (* flush log_file; *)
 108     ""
 109 ;;
 110   
 111 let char1 s   = 
 112   try
 113     (String.sub s 0 1)
 114   with Invalid_argument( ia_s) -> Printf.fprintf log_file "char1: String.sub problem on %s\n" s;
 115     (* flush log_file; *)
 116     ""
 117 ;;
 118 
 119 let char1_c s = (String.get s 0);;
 120  
 121 let char2 s   = 
 122   try
 123      (String.sub s 0 2)
 124   with Invalid_argument( ia_s) -> Printf.fprintf log_file "char2: String.sub problem on %s\n" s;
 125     (* flush log_file; *)
 126     ""
 127 ;;
 128 
 129 (*<
 130   \subsection{Récupération de variables globales\label{sec:keys:glob}}
 131 
 132   Les mots clefs suivants sont associés à des variables "globales" qui seront utilisées pour 
 133   l'en-tête de la documentation.
 134   \def\keyline#1#2#3#4{\tt #1 & \tt #2 & \tt #3 & \tt #4\\}
 135   \def\globalkeys{%
 136   \begin{center}
 137   \begin{tabular}{|l|l|c|c|}\hline
 138    clef & déclencheur & début & fin\\\hline\hline
 139   \keyline{author}{node.author}{'}{'}
 140   \keyline{}{\% author}{'}{'}
 141   \keyline{}{\% auteur}{'}{'}\hline
 142   \keyline{title}{\% titre}{'}{'}
 143   \keyline{}{\% title}{'}{'}\hline
 144   \keyline{project}{\% project}{'}{'}
 145   \keyline{}{\% projet}{'}{'}\hline
 146   \keyline{mailto}{node.mailto}{'}{'}
 147   \keyline{}{\% mailto}{'}{'}\hline
 148   \keyline{date}{node.date}{'}{'}
 149   \keyline{}{\% date}{'}{'}\hline
 150   \keyline{version}{VERSION}{=}{;}
 151   \keyline{}{\% version}{'}{'}\hline
 152   \end{tabular}
 153   \end{center}}\globalkeys
 154   Je vais utiliser la structure suivante :
 155   \begin{itemize}
 156   \item une hashtable qui contient une description de chaque association de clef
 157      (cf tableau plus haut) avec un entier comme index.
 158      Une telle description est une structure de type {\tt key\_pattern}, qui contient comme
 159      champs :
 160      \begin{itemize}
 161      \item {\tt name\_key}    : le nom de la clef.
 162      \item {\tt trigger\_pat} : le "déclencheur"
 163      \item {\tt before\_pat}  : le tag de début
 164      \item {\tt after\_pat}   : le tag de fin
 165      \item {\tt is\_found}    : un booléen qui signale si cette clef a déjà été trouvée dans le texte
 166      \item {\tt value}        : la valeur de la clef
 167      \end{itemize}
 168      Pour résumer, la clef {\tt name\_key} prend sa valeur dans la zone crochetée du pattern :\\
 169      {\tt ... trigger\_pat ... before\_pat [ ... ] after\_pat}
 170   \item un type {\tt Line( string, bool, int)} qui permet de décrire l'état de la ligne en 
 171      cours de recherche de clef.\\
 172      {\tt Line( S, B, K)} décrit la ligne de contenu {\tt S} dans laquelle une clef a déjà été trouvée
 173      si {\tt B} est à {\it true}, et ne l'a pas si {\tt B} est à {\it false}. Lorsque {\tt B} vaut
 174      {\it false} : {\tt K} vaut $-1$, et sinon il vaut le numéro de la clef trouvée.
 175   \end{itemize}
 176 *)
 177 
 178 type key_pattern = { name_key    : string;
 179 		     trigger_pat : string;
 180 		     before_pat  : string;
 181 		     after_pat   : string;
 182 		     mutable is_found    : bool;
 183 		     mutable value       : string;
 184 		   } ;;
 185 
 186 let build_key_pattern name trigger before after =
 187   { name_key    = name;
 188     trigger_pat = trigger;
 189     before_pat  = before;
 190     after_pat   = after;
 191     is_found    = false;
 192     value       = "";
 193   } ;;
 194 
 195 let specify_key_pattern name value =
 196   { name_key    = name;
 197     trigger_pat = not_defined;
 198     before_pat  = not_defined;
 199     after_pat   = not_defined;
 200     is_found    = true;
 201     value       = value;
 202   } ;;
 203 
 204 let keys_counter = ref 0;;
 205 let keys_hashtbl = Hashtbl.create 20;;
 206 
 207 let add_key_pattern name trigger before after =
 208   Hashtbl.add keys_hashtbl !keys_counter 
 209     (build_key_pattern name trigger before after);
 210   keys_counter := !keys_counter + 1
 211 ;;
 212 
 213 let add_specified_key_pattern name value =
 214   Hashtbl.add keys_hashtbl !keys_counter 
 215     (specify_key_pattern name value);
 216   keys_counter := !keys_counter + 1
 217 ;;
 218 
 219 (* one line is the line string X a boolean (found or not) X the key into the hashtable 
 220    a "neutral  line" is (string, false, -1)
 221    a "resolved line" is (string, true, nb) with nb a key in keys_hashtbl
 222    *)
 223 type line_state_for_keys = Line of string * bool * int;;
 224 
 225 (*< 
 226   \subsubsection{Recherche de sous chaînes de charactères}
 227 
 228   Je n'ai pas trouvé en {\sf ocaml} de fonction {\tt String.index\_substring str1 str2} qui
 229   renvoie la position de {\tt str2} dans {\tt str1}.
 230 
 231   J'ai donc implémenté les fonctions {\tt compare\_strings} et {\tt contains\_substring} qui
 232   émulent cette fonctionnalité. J'ai recours pour cela à {\tt contains\_substring\_rec} qui
 233   cherche récursivement la position d'une chaîne dans un string.
 234   *)
 235 let compare_strings str1 str2 =
 236   let len = min (String.length str1) (String.length str2) in
 237     try
 238       String.sub str1 0 len = String.sub str2 0 len
 239     with Invalid_argument( ia_s) -> Printf.fprintf log_file "compare_...: String.sub problem on %s\n" str1;
 240       (* flush log_file; *)
 241       false
 242 ;;
 243 
 244 (* use: contains_substring str substr (String.length str) (String. length substr) 0 
 245    return the index of the end of substr into str, raises Not_found if not found *)
 246 let rec contains_substring_rec str sub_str l sl n =
 247   if char1 str = char1 sub_str then
 248     begin
 249       if compare_strings str sub_str then 
 250 	n + sl
 251       else
 252 	if l > sl then
 253 	  contains_substring_rec (next1 str) sub_str (l - 1) sl (n + 1)
 254 	else
 255 	  raise Not_found;
 256     end
 257   else
 258     if l > sl then
 259       contains_substring_rec (next1 str) sub_str (l - 1) sl (n + 1)
 260     else
 261       raise Not_found;
 262 ;;
 263 
 264 (* I do not understand why this does not exist in ocaml!! 
 265     returns the index of the end of substr into str or raises Not_found *)
 266 let contains_substring str substr =
 267   contains_substring_rec str substr (String.length str) (String.length substr) 0;;
 268 (*> *)
 269 
 270 (*< 
 271   \subsubsection{Recherche des occurences des clefs dans un string}
 272 
 273   J'utilise la fonction {\tt contains\_substring} pour déterminer si une des clefs contenues dans la hashtable 
 274   {\tt keys\_hastbl} est dans un string donné.
 275   *)
 276 (* to be used as : (confront_key_to_string k d str) *)
 277 let confront_key_to_string k key one_line =
 278   match one_line with
 279       Line( content, is_found, _) -> 
 280 	begin
 281 	  if is_found || key.is_found then
 282 	    one_line
 283 	  else
 284 	    try
 285 	      (* If the key trigger is in the line *)
 286 	      let deb = contains_substring content key.trigger_pat in
 287 		begin
 288 		  try
 289 		    Line( String.sub content deb ((String.length content) - deb) , true, k)
 290 		  with Invalid_argument( ia_s) -> 
 291 		    Printf.fprintf log_file "confront_...: String.sub problem on %s\n" content;
 292 		    (* flush log_file; *)
 293 		    Line( content , false, -1)
 294 		end
 295 	    with 
 296 		Not_found -> 
 297 		  Line( content, false, -1)
 298 	end
 299 ;;
 300 (*> *)
 301 
 302 (* to find which key is in the string *)
 303 let has_key one_string =
 304   if String.length one_string = 0 then
 305     false
 306   else
 307     let line_s = Line( one_string, false, -1) in
 308     let is_it_a_key = Hashtbl.fold confront_key_to_string keys_hashtbl line_s in
 309       match is_it_a_key with
 310 	  Line( str, is_found, nb) ->
 311 	    if is_found then
 312 	      let this_key = Hashtbl.find keys_hashtbl nb in
 313 		try
 314 		  (* extraction du morceau important *)
 315 		  let find_first = contains_substring str this_key.before_pat in
 316 		  let first_part = String.sub str find_first ((String.length str) - find_first) in
 317 		  (* en fait c'est bon :
 318 		     - si c'est le dernier
 319 		     - ou si le suivant n'est pas le même  *)
 320 		  let find_last  = contains_substring first_part this_key.after_pat in
 321 		  let this_value = String.sub first_part 0 (find_last - (String.length this_key.after_pat)) in
 322 		    this_key.is_found <- true;
 323 		    this_key.value    <- this_value;
 324 		    Printf.fprintf log_file "KEY: %s -> %s\n" this_value this_key.name_key;
 325 		    Hashtbl.replace keys_hashtbl nb this_key;
 326 		    true;
 327 		with
 328 		    Not_found -> false
 329 		  | Invalid_argument( ia_s) -> 
 330 		      Printf.fprintf log_file "has_key: String.sub problem on %s\n" str;
 331 		      (* flush log_file; *)
 332 		      false
 333 	    else
 334 	      false
 335 ;;
 336 
 337 (* a key value is N x B x S, (N is a key name) where B is false is S is not relevant, true otherwise. *)
 338 type key_value = Key_value of string * bool * string;;
 339 
 340 (* to be used on the keys hashtable to get the value of a key *)
 341 let get_key_value_fold index key current_key_value =
 342   match current_key_value with
 343       Key_value( name, is_found, value) ->
 344 	if is_found then
 345 	  current_key_value
 346 	else
 347 	  if (key.name_key = name) && key.is_found then
 348 	    Key_value( name, true, key.value)
 349 	  else
 350 	    current_key_value
 351 ;;
 352 
 353 (* to get the value of a given key *)
 354 let get_key_value k =
 355   let init_key_value = Key_value( k, false, "") in
 356   let found_result   = Hashtbl.fold get_key_value_fold keys_hashtbl init_key_value in
 357     match found_result with
 358 	Key_value( s, b, value) -> 
 359 	  if b then
 360 	    value
 361 	  else
 362 	    not_defined
 363 ;;
 364 
 365 (* to get all the defined keys *)
 366 let get_keys_names _ = 
 367   let init_gkn = [] in
 368   let add_kname k d init = 
 369     List.append init [ d.name_key]
 370   in
 371   Hashtbl.fold add_kname keys_hashtbl init_gkn
 372 ;;
 373 
 374 (*> *)
 375 
 376 (*> *)
 377 
 378 (*< 
 379   \subsection{Niveau d'étoile}
 380 
 381   Comme cela a été exposé plus haut, les spécifications de {\sf CWEB} précisent différents niveaux
 382   de blocs, marqués par un "étoilage" des marques de début de bloc.
 383 *)
 384 
 385 (* to determine the "star level" of the section mark *)
 386 let star_level str =
 387   let str_l = String.length str in
 388     if str_l < 3 then
 389       (str, Not_relevant)
 390     else
 391       let short_str = next2 str in
 392 	(* Printf.fprintf log_file ">>>| %s\n" str; *)
 393 	Printf.fprintf log_file "***| %s(%c)\n" short_str (char1_c short_str);
 394 	match char1_c short_str with
 395 	    '*' -> 
 396 	      if str_l < 4 then
 397 		(next1 short_str, Star)
 398 	      else
 399 		begin
 400 		  let very_short_str = next1 short_str in
 401 		    Printf.fprintf log_file "***| %s(%c)\n" very_short_str (char1_c very_short_str);
 402 		    match char1_c very_short_str with
 403 			'*'       -> (next1 very_short_str, Double_star)
 404 		      | '0' ..'9' -> (next1 very_short_str, Level( char1 very_short_str))
 405 		      | _         -> (very_short_str, Star)
 406 		end
 407 	  | _   -> (short_str, Not_relevant)
 408 ;;
 409 
 410 (* debug tool *)
 411 let get_star_level l =
 412   match l with
 413       Not_relevant -> "NR"
 414     | Star -> "STAR"
 415     | Double_star -> "2STAR"
 416     | Level( f) -> "Level(" ^ f ^ ")"
 417 ;;
 418 
 419 (*> *)
 420 
 421 (*< caractère de commentaire
 422 Si on le change on accède à n'importe quel langage (sans commentaires de bloc...
 423 *)
 424 let comment_char = ref "%";;
 425 (*> *)
 426 
 427 (*<
 428   \subsection{Explosion d'une ligne et attribution de son type}
 429    La tâche principale est de na pas tenir compte des blanc en début de ligne 
 430    et de repérer les 4 types de marqueurs de début de ligne :
 431   \begin{itemize}
 432   \item {\tt \%\_} pour les commentaires simples
 433   \item {\tt \%\%} pour les début de section
 434   \item {\tt \%<} pour les débuts de sous-section (avec retour charriot)
 435   \item {\tt \%>} pour les fins de sous-section
 436   \end{itemize}
 437   le reste étant du code
 438 *)
 439 let rec explode s = 
 440   if (String.length s) = 0 then
 441     (Into_code, "", Not_relevant)
 442   else
 443     (* before I used a match sentence but it seems that it's not compliant with the use of variables :
 444        let truc = "%";; match str with truc -> alpha | _ -> beta;;
 445        does not work as I imagined *)
 446     if (char1 s) = " " then explode (next1 s)
 447     else
 448       if (char1 s) = (!comment_char) then
 449 	begin
 450 	  if (String.length s) > 1 then
 451 	    (* dans les deux premier cas il faut regarder plus loin pour voir si la section est étoilée *)
 452 	    if (char2 s) = (!comment_char ^ !comment_char) then
 453 	      let (next_s, s_level) = star_level s in
 454 		Printf.fprintf log_file "+++| %s[%s]\n" next_s (get_star_level s_level);
 455 		(Begin_section, next_s, s_level)
 456 	    else
 457 	      if (char2 s) = (!comment_char ^ "<") then
 458 		let (next_s, s_level) = star_level s in
 459 		  Printf.fprintf log_file "+++| %s[%s]\n" next_s (get_star_level s_level);
 460 		  (Begin_subsection, next_s, s_level)
 461 	      else
 462 		if (char2 s) = (!comment_char ^ ">") then
 463 		  (End_subsection, (next2 s), Not_relevant)
 464 		else
 465 		  (Into_comments, (next1 s), Not_relevant)
 466 	  else
 467 	    (Into_comments, (next1 s), Not_relevant)
 468 	end
 469       else
 470 	(Into_code, s, Not_relevant)
 471 ;;
 472 (*> *)
 473 
 474 (*< 
 475   \subsection{debug tools}
 476 
 477   Différentes fonctions de parcours de résultats intermédiaires, destinées à 
 478   du débug.
 479 *)
 480 
 481 (* pour résumer un string*)
 482 let short_string str = (* str ;;*)
 483   try
 484     String.sub str 0 (min (String.length str) 10) 
 485   with Invalid_argument( ia_s) -> 
 486     Printf.fprintf log_file "short_string: String.sub problem on %s\n" str;
 487     (* flush log_file; *)
 488     ""
 489 ;;
 490 
 491 (* pour décrire l'état *)
 492 let say_state (s, str) =
 493   let s_str = short_string str in
 494     match s with
 495 	Begin_section    -> Printf.fprintf log_file "Debut de section      <-- %s\n" s_str 
 496       | Into_comments    -> Printf.fprintf log_file "Dans les commentaires <-- %s\n" s_str 
 497       | Begin_subsection -> Printf.fprintf log_file "Debut de sous section <-- %s\n" s_str 
 498       | End_subsection   -> Printf.fprintf log_file "Fin de sous section   <-- %s\n" s_str 
 499       | Into_code        -> Printf.fprintf log_file "Dans le code          <-- %s\n" s_str 
 500       | Begin_file       -> Printf.fprintf log_file "Tout début de fichier <-- %s\n" s_str 
 501       | _                -> Printf.fprintf log_file "ERREUR!!!<-- %s\n" s_str 
 502 ;;
 503 
 504 (*> *)
 505 
 506 (*< 
 507   \subsection{Structure de blocs\label{title:sec}}
 508   Un bloc (une \code{section}) est composé d'une structure comportant :
 509   \begin{itemize}
 510   \item une référence,
 511   \item un titre,
 512   \item une zone de commentaires,
 513   \item une zone de code.
 514   \end{itemize}
 515 *)
 516 
 517 (* je vais ranger mon code dans un arbre *)
 518 type 'a tree = Empty | Noeud of 'a * 'a tree list;;  
 519 (*type arbre = Empty | Noeud of section * arbre list;; *)
 520 
 521 
 522 (* fabrication d'un noeud vide *)
 523 type section = { refcode  : indented_ref ; 
 524 		 level    : state_level  ;
 525 		 title    : string ; 
 526 		 comments : string ; 
 527 		 code     : string ;
 528 	       };;
 529 
 530 let get_refcode_s d =
 531     match d.refcode with
 532 	Indented_ref( s, _, _) -> s
 533 ;;
 534 
 535 (* pour plus tard *)
 536 let root_section = { refcode  = Indented_ref( root_string, 0, 0);
 537 		     level    = Not_relevant ;
 538 		     title    = "" ; 
 539 		     comments = "" ; 
 540 		     code     = "" ;
 541 		   };;
 542 
 543 (* pour plus tard *)
 544 let empty_section = { refcode  = Indented_ref( empty_string, 0, 0);
 545 		      level    = Not_relevant ;
 546 		      title    = "" ; 
 547 		      comments = "" ; 
 548 		      code     = "" 
 549 		    };;
 550 
 551 (*<
 552   \paragraph{Encapsulation --- mise en page.}~\\
 553   Il s'agit de l'encapsulation d'une section.
 554 *)
 555 
 556 (* se débarasser des charactères spéciaux *)
 557 let rec without_escapes s =
 558   if (String.length s) = 0 then
 559     ""
 560   else
 561     match (char1 s) with
 562       | "}" -> "\\}" ^ (without_escapes (next1 s))
 563       | "{" -> "\\{" ^ (without_escapes (next1 s))
 564       | "_" -> "\\_" ^ (without_escapes (next1 s))
 565       | "^" -> "\\^\\ " ^ (without_escapes (next1 s))
 566       | "#" -> "\\#" ^ (without_escapes (next1 s))
 567       | "\\" -> "\\bs{}" ^ (without_escapes (next1 s))
 568       | _  -> (char1 s) ^ (without_escapes (next1 s))
 569 ;;
 570 
 571 (*<
 572   \paragraph{En ce qui concerne les inclusions.}~\\
 573   Ca se passe là:
 574 *)
 575 let get_relation f =
 576   try
 577     Hashtbl.find relations (get_refcode_s f)
 578   with Not_found ->
 579     Printf.fprintf log_file "--[%s:notfound]\n" (get_refcode_s f);
 580     empty_string
 581 ;;
 582 
 583 let get_subrelations f =
 584   try
 585     Hashtbl.find sub_relations (get_refcode_s f)
 586   with Not_found ->
 587     Printf.fprintf log_file "--[%s:notfound]\n" (get_refcode_s f);
 588     [ empty_string ]
 589 ;;
 590 
 591 let rec pretty_print_rel_list l=
 592     match l with
 593 	[]           -> ""
 594       | head :: tail ->
 595 	  if (head = root_string) || (head = empty_string) then
 596 	    Printf.sprintf "%s" (pretty_print_rel_list tail)
 597 	  else
 598 	    Printf.sprintf "\\refangles{refcode:%s} %s" head (pretty_print_rel_list tail)
 599 ;;
 600 
 601 let pretty_print_relations s empty_comments=
 602   Printf.fprintf log_file "PPR>\n";
 603   let prefix_relations = ref "" in
 604     if empty_comments then
 605       prefix_relations := ""
 606     else
 607       prefix_relations := "~\\\\\n";
 608     let p = get_relation s in
 609     let f = get_subrelations s in 
 610       if p = "0" then
 611 	if (List.length f) = 1 && (((List.hd f) = empty_string) || ((List.hd f) = root_string)) then
 612 	  ""
 613 	else
 614 	  Printf.sprintf "%s{\\footnotesize \\uses %s}" !prefix_relations (pretty_print_rel_list f)
 615       else
 616 	if f = [] then
 617 	  Printf.sprintf "%s{\\footnotesize \\usedby \\refangles{refcode:%s}}" !prefix_relations p 
 618 	else
 619 	  begin
 620 	    if (List.length f) = 1 && (((List.hd f) = empty_string) || ((List.hd f) = root_string)) then
 621 	      Printf.sprintf "%s{\\footnotesize \\usedby \\refangles{refcode:%s}}" !prefix_relations p 
 622 	    else
 623 	      Printf.sprintf "%s{\\footnotesize \\usedby \\anglesref{refcode:%s} --- \\uses %s}" 
 624 		!prefix_relations p (pretty_print_rel_list f)
 625 	  end
 626 ;;
 627 (*> *)
 628 
 629 let pretty_print_level l =
 630   match l with
 631       Not_relevant -> "0"
 632     | Star         -> "10"
 633     | Double_star  -> "100"
 634     | Level( f)    -> f
 635 ;;
 636 
 637 let before_code_symbol = "\\bcodesymbol\n%END LATEX\n\\begin{quote}\n\\begin{alltt}\n";;
 638 let after_code_symbol = "\\end{alltt}\n\\end{quote}\n%BEGIN LATEX\n}\n";;
 639 let before_section_symbol = "\\bsecsymbol";;
 640 
 641 let pretty_print_section sec =
 642   let after_comments_carriage = ref "" in
 643     if sec.comments = "" then
 644       after_comments_carriage := "\n"
 645     else
 646       after_comments_carriage := "~\\\\\n";
 647     match sec.refcode with
 648 	Indented_ref( s, n, c) ->
 649 	  "\\noindent" ^ before_section_symbol ^ "\\nopagebreak\\\\\n" ^ 
 650 	  "\\sectitle{" ^ (pretty_print_level sec.level) ^ "}{" ^ sec.title ^ "}" ^ 
 651 	  "{" ^ (string_of_int c) ^ "}\n" ^ sec.comments ^ !after_comments_carriage ^ 
 652 	  (pretty_print_relations sec (sec.comments = "")) ^ 
 653 	  "\n\n" ^ 
 654 	  "\\nopagebreak\n{\\footnotesize\n" ^
 655 	  before_code_symbol ^ 
 656 	  sec.code ^ 
 657 	  after_code_symbol ;;
 658 
 659 
 660 (* to gain CPU time*)
 661 let process_strings_regexp = (regexp "\([, (\[]'\)\([^']*\)\('\)");;
 662 
 663 (*
 664   Pas mieux pour l'instant:
 665   Test:
 666   # get_strings "ceci est un 'test' '''' assez 'étrange': A' + ['test''m''test', 'test','a'] ('al').";;
 667 *)
 668 let process_strings str = global_replace process_strings_regexp "\1\\stringc{\2}\3" str;;
 669 
 670 (* let process_cmts str = global_replace (regexp "\(%[^']*\)\(\\n\)") "\\cmt{\1}\\2" str;; *)
 671 (* for the "end of line" comments *)
 672 
 673 (* to gain CPU time*)
 674 let colorize_regexps = ref [];;
 675 (* [(regexp "|") ; (regexp "&") ; (regexp "=") ; (regexp "==") ;  (regexp "~") ;  (regexp "<=") ;  (regexp ">=")];; *)
 676 let colorize_regexpr = ref [];;
 677 (* "\\vt" ; "\\va" ;  "\\oeq" ; "\\ooeq" ; "\\otdl" ; "\\(\\leq\\)" ; "\\(\geq\\)" ];;*)
 678 
 679 let colorize_regexp_oo = ref (regexp "\\b\(function\|while\|continue\|try\|catch\|for\|end\|persistent\|switch\|case\|if\|else\|elseif\|return\|break\|otherwise\)\\b");;
 680 
 681 (*< 
 682   \subsection{Déclarations de clefs globales spécifiques à {\sf OCAMAWEB}}
 683 
 684   Je déclare ici les clefs de la section \ref{sec:keys:glob} :
 685   \globalkeys
 686 
 687 *)
 688 
 689 let dvipdfm = ref "<ocamaweb.xml> FILE NOT FOUND";;
 690 let dviext  = ref "<ocamaweb.xml> FILE NOT FOUND";;
 691 
 692 try
 693   let xml_inits = Xml.parse_file ((Sys.getenv "OCAMAWEB") ^ "ocamaweb.xml") in
 694   let caracts = (get_childs xml_inits) in
 695     (* caracts in a list of xml structs, I want the one with 'keypatterns' tag *)
 696   let is_pdfgenerator xml_struct =
 697     (get_name xml_struct) = "pdfgenerator"
 698   in 
 699   let pdfgenerator = match (List.find is_pdfgenerator caracts) with
 700       _,a,_ -> match (List.hd a) with
 701 	  "file", d -> d
 702 	| _ -> "**bad xml file**"
 703   in
 704   let pdfgenerator_ext = match (List.find is_pdfgenerator caracts) with
 705       _,a,_ -> match (List.nth a 1) with
 706 	  "ext", d -> d
 707 	| _ -> "pdf generator ext attribute not found in <ocamaweb.xml>"
 708   in
 709     (* here I want to get the regexps *)
 710   let is_regexp xml_struct =
 711     (get_name xml_struct) = "regexp"
 712   in
 713   let regexp_defs = (get_childs (List.find is_regexp caracts)) in
 714   let regexp_match_mine v =
 715     match v with
 716 	_,a,_ -> a
 717   in
 718   let regexp_info = (List.map regexp_match_mine regexp_defs) in
 719   let get_regexp_from v =
 720     match (List.nth v 0) with
 721 	_,a -> (regexp a)
 722   in
 723   let regexp_from = (List.map get_regexp_from regexp_info) in
 724   let get_regexp_to v =
 725     match (List.nth v 1) with
 726 	_,a -> a
 727   in
 728   let regexp_to = (List.map get_regexp_to regexp_info) in
 729     (* now I have the pdfgenerators name *)
 730   let is_comment_key xml_struct =
 731     (get_name xml_struct) = "commentkey"
 732   in 
 733   let commentkey = match (List.find is_comment_key caracts) with
 734       _,a,_ -> begin
 735 	match (List.hd a) with
 736 	    "value", v -> 
 737 	      (* c'est ici que j'attribue sa nouvelle valeur à |comment_char| *)
 738 	      comment_char := v;
 739 	      v
 740 	  | _ -> "**bad xml file : commentkey not properly defined**"
 741       end
 742   in
 743   let is_keypatterns xml_struct = 
 744     (get_name xml_struct) = "keypatterns" 
 745   in
 746   let key_patterns = (get_childs (List.find is_keypatterns caracts)) in
 747     (* now I have to put the keypatterns into my hashtable *)
 748   let xml_key_atomic_value xml_list n =
 749     let couple = List.nth xml_list n in
 750       match couple with
 751 	  a,b -> b
 752   in
 753   let add_key_pattern_from_xml xml_struct =
 754     match xml_struct with
 755 	name,attribs,childs ->
 756 	  let key_name    = xml_key_atomic_value attribs 0 in
 757 	  let key_sign    = xml_key_atomic_value attribs 1 in
 758 	  let before_name = xml_key_atomic_value attribs 2 in
 759 	  let after_name  = xml_key_atomic_value attribs 3 in
 760 	    add_key_pattern key_name key_sign before_name after_name
 761   in
 762   let is_matlabwords xml_struct = 
 763     (get_name xml_struct) = "matlabwords" 
 764   in
 765   let matlab_words = (get_childs (List.find is_matlabwords caracts)) in
 766     (* now I have to put the matlabwords into a list *)
 767   let extract_name_from_matlabwords xml_struct = 
 768     match xml_struct with
 769 	name,attribs,childs -> 
 770 	  xml_key_atomic_value attribs 0
 771   in
 772     (* here I form a list with all the matlab words *)
 773   let matlabwords_list = List.map extract_name_from_matlabwords matlab_words in
 774   let matlabwords_concat mw_init mw_next = 
 775     (mw_init ^ "\|" ^ mw_next) 
 776   in
 777   let matlabwords_regexp = (regexp ("\\b\(" ^ (List.fold_left matlabwords_concat (List.hd matlabwords_list) (List.tl matlabwords_list) 
 778 					       ^ "\)\\b"))) in
 779     (* here I have got the correct regexp, for instance :
 780        (global_replace matlabwords_regexp "\\ocamawebdefinition{\\0}" "if a==0 then 1 else 2 end;")
 781        returns a correct answer *)
 782     colorize_regexp_oo := matlabwords_regexp; 
 783 
 784     (* get the keypattern informations *)
 785     List.iter add_key_pattern_from_xml key_patterns;
 786 
 787     (* get the pdfgenerator *)
 788     dvipdfm := pdfgenerator;
 789     dviext  := pdfgenerator_ext;
 790     
 791     (* get the regexps *)
 792     colorize_regexps := regexp_from;
 793     colorize_regexpr := regexp_to
 794 
 795 with e -> 
 796   Printf.fprintf stderr "OCAMAWEB: I cannot find <ocamaweb.xml> file in <%s> or this file is not completed\n" (Sys.getenv "OCAMAWEB") ; 
 797   match e with
 798       Not_found    -> Printf.fprintf stderr "NOT FOUND\n"
 799     | Xml_error(e) -> Printf.fprintf stderr "XML error during <ocamaweb.xml> parsing : %s\n" e
 800     | _            -> Printf.fprintf stderr "UNKOWN ERROR\n"
 801   ;
 802   
 803   add_key_pattern "author"  "node.author" "'" "'";
 804   add_key_pattern "author"  "% author"    "'" "'";
 805   add_key_pattern "author"  "% auteur"    "'" "'";
 806   add_key_pattern "title"   "% title"     "'" "'";
 807   add_key_pattern "title"   "% titre"     "'" "'";
 808   add_key_pattern "project" "% project"   "'" "'";
 809   add_key_pattern "project" "% projet"    "'" "'";
 810   add_key_pattern "mailto"  "node.mailto" "'" "'";
 811   add_key_pattern "mailto"  "% mailto"    "'" "'";
 812   add_key_pattern "date"    "node.date"   "'" "'";
 813   add_key_pattern "date"    "% date"      "'" "'";
 814   add_key_pattern "version" "% version"   "'" "'";
 815   add_key_pattern "version" "VERSION"     "=" ";"
 816 ;;
 817 
 818 (*> *)
 819 
 820 
 821 (* to colorize the code parts *)
 822 (* [let garzol = follow_file "sample.m";;] *)
 823 let colorize str =
 824   let internal_str = (global_replace !colorize_regexp_oo "\\ocamawebdefinition{\\0}" (without_escapes str)) in
 825   let regexp_this str regs regr =
 826     (global_replace regs ( "{" ^ regr ^ "}" ) str)
 827   in
 828     process_strings (List.fold_left2 regexp_this internal_str !colorize_regexps !colorize_regexpr) 
 829 (*  let 
 830     process_strings
 831       (global_replace colorize_regexp_1 "{\\vt}"
 832 	 (global_replace colorize_regexp_2 "{\\va}"
 833 	    (global_replace colorize_regexp_3 "{\\oeq}"
 834 	       (global_replace colorize_regexp_4 "{\\ooeq}"
 835 		  (global_replace colorize_regexp_5 "{\\otdl}"
 836 		     (global_replace colorize_regexp_6 "{\\(\\leq\\)}"
 837 			(global_replace colorize_regexp_7 "{\\(\geq\\)}"
 838 			   (global_replace !colorize_regexp_oo "\\ocamawebdefinition{\\0}"
 839 			      (without_escapes str)))))))))
 840 *)    
 841 ;;
 842 
 843 let without_path f =
 844   try
 845     let deb_path = 1 + (String.rindex f '/') in
 846       String.sub f deb_path ((String.length f) - deb_path)
 847   with Not_found ->
 848     try
 849       let deb_path = 1 + (String.rindex f '\\') in
 850 	String.sub f deb_path ((String.length f) - deb_path)
 851     with Not_found ->
 852       f
 853 ;;
 854 
 855 let neutralize_filenames_regexp = (regexp "_");;
 856 
 857 (* juste pour neutraliser les _ et \ dans les noms de (fichiers) *)
 858 let neutralize_filenames str_fname =
 859   let str = without_path str_fname in
 860     try
 861       let ridx = (1 + (String.rindex str '/')) in
 862       let only_filename = String.sub str ridx ((String.length str) - ridx) in
 863 	global_replace neutralize_filenames_regexp "\\_" only_filename
 864     with 
 865 	Not_found -> global_replace neutralize_filenames_regexp "\\_" str
 866 ;;
 867 
 868 let rec first_defined str_lst =
 869   match str_lst with
 870       []           -> not_defined
 871     | head :: tail -> 
 872 	if head = not_defined then
 873 	  first_defined tail
 874 	else
 875 	  head
 876 ;;
 877 
 878 let get_email str =
 879   if str = not_defined then
 880     ""
 881   else
 882     "\\\\{\\tt mailto:" ^ str ^ "}"
 883 ;;
 884 
 885 (* to include ocamaweb.sty file into the LaTeX one *)
 886 let windows_path_to_unix str = global_replace (regexp "[\\]") "/" str;;
 887 
 888 let get_style_path =
 889   try
 890     (windows_path_to_unix (Sys.getenv "OCAMAWEB"))
 891   with Not_found ->
 892     ""
 893 ;;
 894 
 895 let get_first_line _ =
 896   let project_name_v = (get_key_value "project") in
 897     if project_name_v = not_defined then
 898       ""
 899     else
 900       project_name_v ^ "\\\\" 
 901 ;;
 902 
 903 let title_or_filename _ =
 904   let tit = (get_key_value "title") in 
 905   if tit = not_defined then
 906     (get_key_value "filename")
 907   else
 908     tit
 909 ;;
 910 
 911 
 912 let head_of_file _ =
 913   let all_knames = 
 914     (* all_knames_full sans les doublons ni filename *)
 915     let uniquel clist str =
 916       let this_equal v = 
 917 	(str = v) 
 918       in
 919 	(* filename keyword is a very special one *)
 920 	if (not (List.exists this_equal clist)) && (not (str = "filename")) then
 921 	  (List.append clist [ str ])
 922 	else
 923 	  clist
 924     in
 925       List.fold_left uniquel [] (get_keys_names ())
 926   in
 927   let form_latexdef kname =
 928     "\\def\\ocamaweb" ^ kname ^ "{" ^ (get_key_value kname) ^ "}\n"
 929   in
 930   let all_kvalues = String.concat "" (List.map form_latexdef all_knames) in 
 931     "\\ifx\\firstocamaweb\\undefined\n" ^
 932     "\\input{" ^ get_style_path ^ "ocamaweb.sty}\n\n" ^
 933     "\\fi\n" ^
 934     (* filename keyword is a very special one *)
 935     "\\def\\ocamawebtitle{" ^ (title_or_filename ()) ^ "}\n" ^
 936     "\\def\\ocamawebfilename{" ^ (get_key_value "filename") ^ "}\n" ^ 
 937     "\\def\\ocamawebv{" ^ version ^ "}\n" ^
 938     all_kvalues ^ 
 939     (* 
 940        "\\def\\ocamawebauthor{" ^ (get_key_value "author") ^ "}\n" ^
 941        "\\def\\ocamawebproject{" ^ (get_key_value "project") ^ "}\n" ^
 942        "\\def\\ocamawebfilename{" ^ (get_key_value "filename") ^ "}\n" ^
 943        "\\def\\ocamawebmailto{" ^ (get_key_value "mailto") ^ "}\n" ^
 944        "\\def\\ocamawebdate{" ^ (get_key_value "date") ^ "}\n" ^
 945        "\\def\\ocamawebversion{" ^ (get_key_value "version") ^ "}\n\n" ^
 946     *)
 947     "\n\\ocamawebstart\n\n"
 948 ;;
 949 (*
 950    "\\title{" ^ 
 951    (get_first_line ()) ^ 
 952    (first_defined [(get_key_value "title")   ; (get_key_value "filename") ]) ^ "}\n" ^
 953    "\\author{"  ^ (get_key_value "author") ^ (get_email (get_key_value "mailto")) ^ "}\n" ^
 954    "\\date{Imprimé le \\today,\\\\dernière modification le " ^ (get_key_value "date") ^ "}\n" ^
 955    "\\ocamawebstart\n\n";; 
 956 *)
 957 
 958 let foot_of_file =
 959   "\n\\noindent\\rule{5cm}{1pt}\\nopagebreak\\\\\n\\ocamawebend\n";;
 960 
 961 (*> *)
 962 
 963 (*< 
 964   \subsection{fonctions de manipulation de l'arbre}
 965 
 966   Un arbre est ou bien vide, ou bien un \code{Noeud} contenant un label
 967   et une liste de n\oe uds.\\
 968 
 969   L'arbre d'un fichier est donc une racine qui a comme fils les blocs 
 970   principaux. Chaque bloc principal a comme fils les blocs arbitraire qu'il
 971   contient et de même chaque bloc arbitraire a comme fils les blocs 
 972   arbitraire qu'il contient.\\
 973 
 974   Le label d'un n\oe ud est composé d'une section (cf \ref{title:sec}).
 975 *)
 976 
 977 (* pour résoudre un problème d'empilage: je vais créer une fonction
 978    qui inverse l'ordre du premier niveau de l'arbre *)
 979 let reverse_sons t =
 980   match t with 
 981       Empty -> t
 982     | Noeud(s, f) -> (* je vais inverser l'ordre des fils |f| et les remettre dans s: *)
 983 	Noeud(s, List.rev f)
 984 ;;
 985 
 986 
 987 (* affiche un titre *)
 988 let print_title s =
 989   Printf.fprintf stdout "%s%s\n" (String.make 1 ' ') s.title;;
 990 
 991 (* listing des titres des noeuds d'un arbre *)
 992 let rec get_section = function
 993     Empty -> empty_section
 994   | Noeud(s, _) -> s
 995 ;;
 996 
 997 (* liste les différents titres d'un arbre *)
 998 let rec get_t nb n =
 999   match n with
1000       Empty -> Printf.fprintf stdout "%s\n" (String.make nb '@');
1001     | Noeud(s, l) -> 
1002 	begin
1003 	  Printf.fprintf stdout "%s%s\n" (String.make nb '@') s.title;
1004 	  ignore (List.map (get_t (2 + nb)) l);
1005 	end;
1006 ;;
1007 
1008 (* liste les différents commentaires d'un arbre *)
1009 let rec get_c nb n =
1010   match n with
1011       Empty -> ignore (Printf.fprintf stdout "%s\n" (String.make nb '@'));
1012     | Noeud(s, l) -> 
1013 	begin
1014 	  Printf.fprintf stdout "%s%s\n%s\n" (String.make nb '@') s.title s.comments;
1015 	  ignore (List.map (get_c (2 + nb)) l);
1016 	end;
1017 	()
1018 ;;
1019 
1020 (*< 
1021   \paragraph{remplissage d'un vecteur avec la correspondance péres --- fils.}~\\
1022   J'utilise deux variables globales pour cela (je sais ce n'est pas très élégant, mais je
1023   suis pressé pour l'instant). Ces deux variables sont remplies à la fin du parsing.
1024   
1025   Il s'agit de Hashtables qui contiennent respectivement les fils et les pères de chaque
1026   section.
1027  *)
1028 
1029 let concat_subrelation k v =
1030   try
1031     let l = Hashtbl.find sub_relations k in
1032       Hashtbl.replace sub_relations k (List.append l [ v])
1033   with Not_found ->
1034     Hashtbl.add sub_relations k [v]
1035 ;;
1036 
1037 let get_ref_number s =
1038   match s.refcode with
1039       Indented_ref(_, _, s) -> (string_of_int s)
1040 ;;
1041 
1042 let add_to_relations f d =
1043   (* Printf.fprintf stdout "REL> %s --son of-- %s\n"    (get_refcode_s d) (get_refcode_s f); *)
1044   Hashtbl.add relations (get_refcode_s d) (get_ref_number f);
1045   (* Printf.fprintf stdout "REL> %s --father of-- %s\n" (get_refcode_s f) (get_refcode_s d); *)
1046   concat_subrelation (get_refcode_s f) (get_ref_number d)
1047 ;;
1048 
1049 (* renseigne récursivement les hashtables d'indexation des pères et fils *)
1050 let rec build_relations_rec f a_tree = 
1051     match a_tree with
1052 	Empty -> ()
1053       | Noeud(desc, fils) -> 
1054 	  add_to_relations f desc;
1055 	  ignore (List.map (build_relations_rec desc) fils)
1056 ;;
1057 
1058 (*> *)
1059 
1060 (*<
1061   \paragraph{Affichage itératif des fils de la racine d'un arbre.}~\\
1062   C'est une des fonctions importantes du code, elle appelle \code{son_to_string}
1063   sur toutes les branches de l'arbre.
1064 *)
1065 
1066 (* affichage du contenu d'un élément puis de ses fils comme déclarations de blocs *)
1067 let rec son_to_string str l_tree =
1068   match l_tree with 
1069       Empty -> str
1070     | Noeud(t, l) -> 
1071 	str ^ (pretty_print_section t ) ^ (List.fold_left son_to_string "" l)
1072 ;;
1073 
1074 let to_string t =
1075   match t with
1076       Empty -> "";
1077     | Noeud(s, l) -> (* j'ai les noeud principaux,
1078 			je vais afficher :
1079 			- le contenu du premier avec un code c
1080 			- puis ses blocs de référence
1081 			- puis pour chaque autre élément de la liste :
1082 			- le contenu du premier
1083 			- puis ses blocs de référence
1084 		     *)
1085 	let first = List.nth l 0 in 
1086 	  List.fold_left son_to_string "" l
1087 ;;
1088 (*> *)
1089 
1090 (*> *)
1091 
1092 (*> *)
1093 
1094 (*> *)
1095 
1096 (*< 
1097   \section{file parsing}
1098  *)
1099 
1100 (* récupération de l'état d'une ligne *)
1101 let get_line_state (s, _, _) = s;;
1102 let get_line_str   (_, s, _) = s;;
1103 let get_line_level (_, _, l) = l;;
1104 
1105 (* croisement de l'état global et de celui d'une ligne.
1106    C'est LA grosse machine à états du parseur
1107 *)
1108 let cross_states g_state pline =
1109   let this_level = get_line_level pline in
1110   let l_state    = get_line_state pline in
1111   let str        = short_string (get_line_str   pline) in
1112     match g_state with
1113 	Begin_section | Into_comments | Begin_subsection   -> begin
1114 	  match l_state with
1115 	      Begin_section    -> Printf.fprintf log_file "a(1) new section: %s ...\n" str;
1116 		( Begin_section, New_section, this_level)
1117 	    | Into_comments    -> Printf.fprintf log_file "b(2) add comments to current (sub?)section: %s ...\n" str;
1118 		( Into_comments, Add_comment, this_level)
1119 	    | Begin_subsection -> Printf.fprintf log_file "c(3) new subsection (insert into former code): %s ...\n" str;
1120 		( Begin_subsection, New_subsection, this_level)
1121 	    | End_subsection   -> Printf.fprintf log_file "d(4) close current (sub)section: %s ...\n" str;
1122 		( End_subsection, Close_subsection, this_level)
1123 	    | Into_code        -> Printf.fprintf log_file "e(5) close comment part and begin code part: %s ...\n" str;
1124 		( Into_code, Add_code, this_level)
1125 	    | Begin_file       -> Printf.fprintf log_file "f(*) ERROR!!: %s ...\n" str;
1126 		( Unknown, Stop, this_level)
1127 	    | _                -> ( Unknown, Stop, this_level)
1128 	end;
1129       | End_subsection | Into_code   -> begin
1130 	  match l_state with
1131 	      Begin_section    -> Printf.fprintf log_file "g(1) new section: %s ...\n" str;
1132 		( Begin_section, New_section, this_level)
1133 	    | Into_comments    -> Printf.fprintf log_file "h(6) stay into code: %s ...\n" str;
1134 		( Into_code, Add_comments_into_code, this_level)
1135 	    | Begin_subsection -> Printf.fprintf log_file "i(3) new subsection (insert into former code): %s ...\n" str;
1136 		( Begin_subsection, New_subsection, this_level)
1137 	    | End_subsection   -> Printf.fprintf log_file "j(4) close current (sub)section: %s ...\n" str;
1138 		(End_subsection, Close_subsection, this_level)
1139 	    | Into_code        -> Printf.fprintf log_file "k(6) stay into code: %s ...\n" str;
1140 		(Into_code, Add_code, this_level)
1141 	    | Begin_file       -> Printf.fprintf log_file "l(*) ERROR!!: %s ...\n" str;
1142 		(Unknown, Stop, this_level)
1143 	    | _                -> ( Unknown, Stop, this_level)
1144 	end;
1145       | Begin_file       ->begin
1146 	  match l_state with
1147 	      Begin_section    -> Printf.fprintf log_file "m(7) compose the first section: %s ...\n" str;
1148 		(Into_comments, Into_first_section, this_level)
1149 	    | Into_comments    -> Printf.fprintf log_file "n(8) stay into Begin_file (add to code): %s ...\n" str;
1150 		(Begin_file, Add_code, this_level)
1151 	    | Begin_subsection -> Printf.fprintf log_file "o(*) ERROR!!: %s ...\n" str;
1152 		(Unknown, Stop, this_level)
1153 	    | End_subsection   -> Printf.fprintf log_file "p(*) ERROR!!: %s ...\n" str;
1154 		(Unknown, Stop, this_level)
1155 	    | Into_code        -> Printf.fprintf log_file "q(8) stay into Begin_file (add to code): %s ...\n" str;
1156 		(Begin_file, Add_code, this_level)
1157 	    | Begin_file       -> Printf.fprintf log_file "l(*) ERROR!!: %s ...\n" str;
1158 		( Unknown, Stop, this_level)
1159 	    | _                -> ( Unknown, Stop, this_level)
1160 	end;
1161       | _ -> ( Unknown, Stop, this_level)
1162 ;;
1163 
1164 (* variable globale *)
1165 let global_state = ref Begin_file ;;
1166 
1167 (*< 
1168   \section{outils de manipulation de fichier}
1169  *)
1170 
1171 (* renvoie tout avant le premier ["."] rencontré *)
1172 let title_part str_ = 
1173   if String.length str_ = 0 then
1174     ""
1175   else
1176     let spaces_nb = ref 0 in
1177       try
1178 	while (String.sub str_ !spaces_nb 1= " ") do
1179 	  spaces_nb := !spaces_nb + 1
1180 	done;
1181 	let str = String.sub str_ !spaces_nb (String.length str_ - !spaces_nb) in
1182 	  begin
1183 	    try
1184 	      let point_pos = String.index str '.' in
1185 		if point_pos > 0 then
1186 		  String.sub str 0 point_pos
1187 		else
1188 		  ""
1189 	    with 
1190 		Not_found -> str
1191 	  end
1192       with Invalid_argument( ia_s) -> 
1193 	Printf.fprintf log_file "title_part: String.sub problem on %s\n" str_;
1194 	(* flush log_file; *)
1195 	str_
1196 ;;
1197 
1198 (* renvoie tout après le premier ["."] rencontré *)
1199 let comment_part str = 
1200   try
1201     let point_pos = String.index str '.' in
1202     let str_len   = String.length str in
1203       if str_len > (1 + point_pos) then
1204 	String.sub str (1 + point_pos) ( str_len - point_pos - 1)
1205       else
1206 	""
1207   with 
1208       Not_found -> ""
1209 ;;
1210 
1211 (* I had my xml parsing functions here *)
1212 
1213 (*< 
1214   \subsection{Parsing spécifique aux langages sans commentaires par blocs}
1215 
1216   Cette partie doit être remplacée par une autre pour les langages (comme le {\tt c} ou {\tt ocaml})
1217   qui offrent la possibilité de créer des blocs de commentaires ({\tt /* ... */} ou {\tt (* *)}).
1218 *)
1219 
1220 let refcode_counter = ref 0;;
1221 
1222 let make_generic_refcode str_ dec = 
1223   refcode_counter := !refcode_counter + 1 - dec;
1224   if String.length str_ = 0 then
1225     Indented_ref ("", 0, !refcode_counter)
1226   else
1227     let spaces_nb = ref 0 in
1228       while (String.sub str_ !spaces_nb 1= " ") do
1229 	spaces_nb := !spaces_nb + 1
1230       done;
1231       let str = String.sub str_ !spaces_nb (String.length str_ - !spaces_nb) in
1232       let (str_unstar, s) = star_level str in
1233       let title = title_part str_unstar in
1234 	(* Printf.fprintf log_file "RRR> %s\n-*-> %s\n" str str_unstar; *)
1235 	if dec = 1 then
1236 	  begin
1237 	    Printf.fprintf log_file "RR1> %s |%d|%d (%d)\n" title !spaces_nb (!refcode_counter + dec) dec;
1238 	    Indented_ref (title, !spaces_nb, !refcode_counter + dec);
1239 	  end
1240 	else
1241 	  begin
1242 	    Printf.fprintf log_file "RR0> %s |%d|%d (%d)\n" str 0 (!refcode_counter + dec) dec;
1243 	    Indented_ref (str, 0, !refcode_counter + dec)
1244 	  end
1245 ;;
1246 (* renvoie un refcode pour le string :
1247    un "nettoyage" (pour WEB) de la partie du string avant le 1er ["."] rencontré.
1248    D'abord j'enlève (et je compte) le nombre d'espaces qu'il y a avant
1249 *)
1250 let make_refcode str_ =
1251   make_generic_refcode str_ 0;;
1252 
1253 (* le même mais dans le vide *)
1254 let make_fake_refcode str_ =
1255   make_generic_refcode str_ 1;;
1256 
1257 
1258 (* référence un bloc par refcode (les retours charriot ne sont pas compris) *)
1259 let insert_refcode my_refcode = 
1260   match my_refcode with
1261     |  Indented_ref( s, n, c) ->
1262 	 (String.make n ' ') ^ "\\refcode{" ^ s ^ "}{" ^ (string_of_int c) ^ "}" ;;
1263 
1264 (* declare un bloc par refcode (les retours charriot ne sont pas compris) 
1265 let declare_refcode str = "@<" ^ str ^ "@>=";;
1266 
1267 let end_of_first_comments = "@c\n";;
1268 let end_of_comments       = "@p\n";;
1269 *)
1270 
1271 (*> *)
1272 
1273 (*> *)
1274 
1275 (*<
1276   \section{Traitements principaux}
1277 *)
1278 
1279 (* j'ai besoin d'une racine :
1280    une liste de noeuds (je la met à l'extérieur pour que cela ne soit pas trop récursif -mal de tête-) *)
1281 let root_nodes = ref [];;
1282 
1283 let regexp_no_tabs = regexp "[\t]";;
1284 
1285 (*<
1286   \subsection{parcours récursif d'un fichier (channel)}
1287 *)
1288 let rec make_section first_line channel_name first_line_level =
1289   let refcode_     = ref (Indented_ref("", 0, 0)) in
1290   let title_       = ref "" in
1291   let level_       = ref first_line_level in
1292   let comments_    = ref "" in
1293   let code_        = ref "" in
1294   let into_parsing = ref true in
1295   let fils         = ref [] in
1296     if !global_state <> Begin_file then
1297       begin
1298 	title_    := title_part first_line;
1299 	comments_ := comment_part first_line;
1300 	refcode_  := make_refcode first_line;
1301 
1302 	Printf.fprintf log_file "**>> %s\n" (get_star_level !level_);
1303       end;
1304     
1305     (* tant je ne dois pas créer une section de façon récursive *)
1306     while !into_parsing do
1307       (* flush log_file; *)
1308       try
1309 	let this_line = 
1310 	  (global_replace regexp_no_tabs " " (input_line channel_name)) in
1311 	let has_any_special_keys = has_key this_line in
1312 	let this_parsed_line     = explode this_line in
1313 	let this_str             = (get_line_str this_parsed_line) in
1314 	let carriage             = "\n" in
1315 	let (new_state, this_action, this_state_level) = cross_states !global_state this_parsed_line in
1316 
1317 	  global_state := new_state;
1318 
1319 	  (* j'ai remplacé certains this_str par des this_line car pour l'instant
1320 	     j'utiliser le package alltt, j'espère bien y remédier... *)
1321 	  match this_action with
1322 	      Add_comment            -> comments_ := !comments_ ^ carriage ^ this_str
1323 		(* ATTENTION: je devrais chercher les commentaires de fin de ligne 
1324 		   problème des '%'!!! *)
1325 	    | Add_code               -> code_     := !code_     ^ carriage ^ (colorize this_line)
1326 	    | Add_comments_into_code -> code_     := !code_     ^ carriage ^ "\comments{" ^ this_str ^ "}"
1327 	    | New_section            ->
1328 		begin
1329 		  Printf.fprintf log_file "*>>> (%s)%s\n" this_str (get_star_level this_state_level);
1330 		  root_nodes := !root_nodes @ [ (make_section this_str channel_name this_state_level) ]; 
1331 		  (* root_nodes := [ (make_section this_str channel_name) ] @ !root_nodes; :pas bon du tout *)
1332 		  into_parsing := false
1333 		end;
1334 	    | New_subsection -> 
1335 		begin
1336 		  code_    := !code_ ^ carriage ^ (insert_refcode (make_fake_refcode this_line)); (* this_str *)
1337 		  Printf.fprintf log_file "*>>> (%s)%s\n" this_str (get_star_level this_state_level);
1338 		  fils     := !fils  @ [ (make_section this_str channel_name this_state_level) ]
1339 		end;
1340 	    | Into_first_section -> 
1341 		begin
1342 		  title_    := title_part     this_str;
1343 		  level_    := get_line_level this_parsed_line;
1344 		  comments_ := comment_part   this_str;
1345 		  refcode_  := make_refcode   this_str;
1346 		end;
1347 	    | Close_subsection -> into_parsing := false
1348 	    | Stop             -> into_parsing := false	    
1349 		
1350 	  with End_of_file -> into_parsing := false
1351 	    
1352     done;
1353 
1354     (* je renvoie un noeud quicontient la description de cette section *)
1355     let this_section = { refcode  = !refcode_ ; 
1356 			 level    = !level_ ;
1357 			 title    = !title_ ; 
1358 			 comments = !comments_ ; 
1359 			 code     = !code_
1360 		       } in
1361       Noeud( this_section, !fils )
1362 ;;
1363 (*> *)
1364 
1365 (*<
1366   \subsection{fonction principale}
1367   \begin{itemize}
1368   \item ouverture du fichier
1369   \item mise à "vide" de l'ensemble des noeuds racine
1370   \item mise à \code{Begin_file} du \code{global_state}
1371   \item lancement du parcours recursif
1372   \end{itemize}
1373 *)
1374 let follow_file fname =
1375   root_nodes   := [];
1376   global_state := Begin_file ;
1377   add_specified_key_pattern "filename" (neutralize_filenames fname) ;
1378   let this_channel = open_in fname in
1379     let first_node   = make_section "" this_channel Not_relevant in
1380       (* attention: je fais ici un List.rev pour supprimer un comportement INEXPLIQUE:
1381 	 le premier niveau de liste se retrouve empilé à l'envers! *)
1382     let all_nodes    = Noeud( root_section, List.rev (!root_nodes @ [ first_node ])) in
1383       flush log_file;
1384       all_nodes
1385 ;;
1386 
1387 (*> *)
1388 
1389 (*< 
1390   \subsection{for testing purpose}
1391  *)
1392 
1393 let send_to_file a_tree filename =
1394   build_relations_rec empty_section a_tree;
1395   let this_chan = open_out_bin filename in
1396     Printf.fprintf this_chan "%s%s%s" (head_of_file ()) (to_string a_tree) foot_of_file;
1397     close_out this_chan
1398 ;;
1399 
1400 let without_ext f =
1401   let deb_ext = String.rindex f '.' in
1402     String.sub f 0 deb_ext
1403 ;;
1404 
1405 let rec move_files name dest exts =
1406   match exts with
1407       [] -> 0
1408     | head :: tail ->
1409 	(Sys.command( "move " ^ name ^ head ^ " " ^ dest)) + 
1410 	move_files name dest tail
1411 ;;
1412 
1413 let get_dest_path =
1414   try
1415     (Sys.getenv "OCAMAWEB_DEST")
1416   with Not_found ->
1417     Printf.fprintf log_file "ENV: OCAMAWEB_DEST not found!!!\n";
1418     ""
1419 ;;
1420 
1421 let latexize f mode =
1422   let rez = ref 0 in
1423   let new_f   = without_ext f in
1424     rez := !rez + (Sys.command( "del " ^ get_dest_path ^ (without_path new_f) ^ ".* "));
1425     rez := !rez + 2 * (Sys.command( "latex " ^ (without_path f)));
1426     rez := !rez + 4 * (Sys.command( "latex " ^ (without_path f)));
1427     rez := !rez + 8 * (Sys.command( !dvipdfm ^ " " ^ (without_path new_f) ^ !dviext));
1428     if mode = 2 then
1429       begin
1430 	!rez + 100  * (move_files (without_path (without_ext f))
1431 			 (Sys.getenv "OCAMAWEB_DEST")
1432 			 [ ".pdf" ; ".tex" ; ".dvi" ; ".log" ; ".aux" ; ".toc" ; ".ps"] );
1433       end
1434     else 
1435       !rez + 16;
1436 ;;
1437 
1438 let ocamaweb_process f1 f2 mode =
1439   Printf.fprintf stderr "%s --> %s\n" f1 f2;
1440     let garzol = follow_file f1 in 
1441       if mode < 3 then
1442 	begin
1443 	  send_to_file garzol (without_path f2);
1444 	  latexize f2 mode
1445 	end
1446       else
1447 	begin
1448 	  send_to_file garzol f2;  
1449 	  1
1450 	end
1451 ;;
1452 
1453 
1454 let main () =
1455   Printf.fprintf stderr "OCAMAWEB version-%s\n" version;
1456   if !Sys.interactive then
1457     begin
1458       2
1459     end
1460   else
1461     begin
1462       match Array.length Sys.argv with 
1463 	    2 -> 
1464 	      let file_to_comment = Sys.argv.(1) in
1465 	      let file_to_write   = (Sys.getenv "OCAMAWEB_DEST") ^ 
1466 				    (without_path (without_ext file_to_comment)) ^ ".tex" in
1467 		ocamaweb_process file_to_comment file_to_write 2
1468 	  | 3 ->
1469 	      let file_to_comment = Sys.argv.(1) in
1470 	      let file_to_write   = Sys.argv.(2) in
1471 		ocamaweb_process file_to_comment file_to_write 3
1472 	  | _ -> 
1473 	      ignore (Printf.fprintf stdout "ocamaweb input_file.m [output_file.tex]\n");
1474 	      
1475       close_out log_file;
1476       1;
1477     end
1478 ;;
1479 
1480 main ();;
1481 
1482 
1483 
1484 (*> *)
1485 
1486 (*> *)
1487 


hijacker
hijacker
hijacker
hijacker