helm/DEVEL/pxp/pxp/examples/readme/to_text.ml

   1 (* $Id$
   2  * ----------------------------------------------------------------------
   3  *
   4  *)
   5
   6 open Pxp_types
   7 open Pxp_document
   8
   9
  10 (**********************************************************************)
  11 (* The box class represents formatted text                            *)
  12 (**********************************************************************)
  13
  14 class type formatted_text =
  15   object
  16     method output : int -> int -> out_channel -> unit
  17         (* output initial_indent indent ch:
  18          * 'initial_indent' is how far the first line should be indented;
  19          * 'indent' how far the rest. 'ch' is the channel on which the lines
  20          * are to be printed.
  21          *)
  22
  23     method multiline : bool
  24         (* whether the box occupies multiple lines *)
  25
  26     method width_of_last_line : int
  27         (* returns the width of the last line *)
  28   end
  29 ;;
  30
  31
  32 type text =
  33     Text of string
  34   | Box of formatted_text
  35 ;;
  36
  37
  38 let textwidth tl =
  39   let rec compute tl r =
  40     match tl with
  41         [] -> r
  42       | t :: tl' ->
  43           begin match t with
  44               Text s ->
  45                  compute tl' (r + String.length s)
  46             | Box b ->
  47                 if b # multiline then
  48                   compute tl' (b # width_of_last_line)
  49                 else
  50                   compute tl' (r + b # width_of_last_line)
  51           end
  52   in
  53   compute (List.rev tl) 0
  54 ;;
  55
  56
  57 class box the_initial_width the_width =
  58   object (self)
  59
  60     (* The 'initial_width' is the width that is available on the first
  61      * line of output; the 'width' is the width that is available in the
  62      * rest.
  63      *)
  64
  65     val initial_width = the_initial_width
  66     val width = the_width
  67
  68     (* state: *)
  69
  70     val mutable space_added = false
  71     val mutable linefeed_added = false
  72     val mutable is_first_line = true
  73     val mutable lines = []
  74         (* lines in reverse order (first line = last element) *)
  75     val mutable current_line = []
  76         (* not member of 'lines'; again reverse order *)
  77     val mutable current_indent = 0
  78
  79     method add_space =
  80       if not space_added then begin
  81         space_added <- true;
  82         linefeed_added <- true;
  83         current_line <- Text " " :: current_line
  84       end
  85
  86     method ignore_space =
  87       space_added <- true;
  88       linefeed_added <- true
  89
  90     method add_linefeed =
  91       if not linefeed_added then begin
  92         linefeed_added <- true;
  93         if not space_added then
  94           current_line <- Text " " :: current_line
  95       end
  96
  97     method ignore_linefeed =
  98       linefeed_added <- true
  99
 100     method add_newline =
 101       lines <- current_line :: lines;
 102       current_line <- [];
 103       space_added <- true;
 104       linefeed_added <- true;
 105       is_first_line <- false;
 106       current_indent <- 0;
 107
 108     method add_word s =
 109       (* first try to add 's' to 'current_line' *)
 110       let current_line' = Text s :: current_line in
 111       let current_width =
 112         if is_first_line then initial_width else width in
 113       if textwidth current_line' + current_indent <= current_width then begin
 114         (* ok, the line does not become too long *)
 115         current_line <- current_line';
 116         space_added <- false;
 117         linefeed_added <- false
 118       end
 119       else begin
 120         (* The line would be too long. *)
 121         lines <- current_line :: lines;
 122         current_line <- [Text s];
 123         space_added <- false;
 124         linefeed_added <- false;
 125         is_first_line <- false;
 126         current_indent <- 0;
 127       end
 128
 129     method add_box b =
 130       current_line <- Box b :: current_line;
 131       space_added <- false;
 132       linefeed_added <- false;
 133
 134
 135     method width_of_last_line =
 136       textwidth current_line + current_indent
 137
 138
 139     method available_width =
 140       let current_width =
 141         if is_first_line then initial_width else width in
 142       current_width - textwidth current_line - current_indent
 143
 144
 145     method multiline =
 146       lines <> [] or
 147       (List.exists
 148          (function
 149               Text _ -> false
 150             | Box b -> b # multiline)
 151          current_line)
 152
 153     method output initial_indent indent ch =
 154       let eff_lines =
 155         List.rev
 156           (current_line :: lines) in
 157       let rec out_lines cur_indent ll =
 158         match ll with
 159             [] ->  ()
 160           | l :: ll' ->
 161               output_string ch (String.make cur_indent ' ');
 162               List.iter
 163                 (function
 164                      Text s ->
 165                        output_string ch s
 166                    | Box b ->
 167                        b # output 0 indent ch
 168                 )
 169                 (List.rev l);
 170               if ll' <> [] then
 171                 output_string ch "\n";
 172               out_lines indent ll'
 173       in
 174       out_lines initial_indent eff_lines
 175   end
 176 ;;
 177
 178
 179 class listitem_box listmark indent totalwidth =
 180   let initial_newline = String.length listmark >= indent in
 181   object (self)
 182     inherit box totalwidth (totalwidth - indent) as super
 183
 184     val extra_indent = indent
 185
 186     initializer
 187     self # add_word listmark;
 188     if initial_newline then
 189       self # add_newline
 190     else begin
 191       current_line <- Text (String.make (indent - String.length listmark) ' ')
 192                       :: current_line;
 193       space_added <- true;
 194       linefeed_added <- true;
 195     end
 196
 197
 198     method output initial_indent indent ch =
 199       super # output initial_indent (indent + extra_indent) ch
 200   end
 201 ;;
 202
 203
 204 (**********************************************************************)
 205 (* Footnotes etc.                                                     *)
 206 (**********************************************************************)
 207
 208
 209 class type footnote_printer =
 210   object
 211     method footnote_to_box : store_type -> box -> unit
 212   end
 213
 214 and store_type =
 215   object
 216     method alloc_footnote : footnote_printer -> int
 217     method print_footnotes : box -> unit
 218   end
 219 ;;
 220
 221
 222 class store =
 223   object (self)
 224
 225     val mutable footnotes = ( [] : (int * footnote_printer) list )
 226     val mutable next_footnote_number = 1
 227
 228     method alloc_footnote n =
 229       let number = next_footnote_number in
 230       next_footnote_number <- number+1;
 231       footnotes <- footnotes @ [ number, n ];
 232       number
 233
 234     method print_footnotes (b : box) =
 235       if footnotes <> [] then begin
 236         b # add_newline;
 237         b # add_newline;
 238         let w = b # available_width in
 239         b # add_word (String.make (w/3) '-');
 240         b # add_newline;
 241         b # add_newline;
 242         List.iter
 243           (fun (_,n) ->
 244              n # footnote_to_box (self : #store_type :> store_type) b)
 245           footnotes;
 246         b # add_newline;
 247       end
 248   end
 249 ;;
 250
 251
 252
 253 (**********************************************************************)
 254 (* The extension objects                                              *)
 255 (**********************************************************************)
 256
 257
 258 class virtual shared =
 259   object (self)
 260
 261     (* --- default_ext --- *)
 262
 263     val mutable node = (None : shared node option)
 264
 265     method clone = {< >}
 266     method node =
 267       match node with
 268           None ->
 269             assert false
 270         | Some n -> n
 271     method set_node n =
 272       node <- Some n
 273
 274     (* --- virtual --- *)
 275
 276     method virtual to_box : store -> box -> unit
 277       (* to_box store b:
 278        * formats the element using box 'b'
 279        *)
 280   end
 281 ;;
 282
 283
 284 class only_data =
 285   object (self)
 286     inherit shared
 287
 288     val white_space_re = Str.regexp "[ \t]+\\|\n"
 289
 290     method to_box store b =
 291       let s = self # node # data in
 292       let splitted = Str.full_split white_space_re s in
 293       List.iter
 294         (function
 295              Str.Delim "\n" ->
 296                b # add_linefeed
 297            | Str.Delim _ ->
 298                b # add_space
 299            | Str.Text s ->
 300                b # add_word s)
 301         splitted
 302   end
 303 ;;
 304
 305
 306 class no_markup =
 307   object (self)
 308     inherit shared
 309
 310     method to_box store b =
 311       List.iter
 312         (fun n -> n # extension # to_box store b)
 313         (self # node # sub_nodes)
 314   end
 315 ;;
 316
 317
 318 class readme =
 319   object (self)
 320     inherit shared
 321
 322     method to_box store b =
 323       let title =
 324         match self # node # attribute "title" with
 325             Value s -> s
 326           | _ -> assert false
 327       in
 328       let w = b # available_width in
 329       let line = String.make (w-1) '*' in
 330       b # add_word line;
 331       b # add_newline;
 332       b # add_word title;
 333       b # add_newline;
 334       b # add_word line;
 335       b # add_newline;
 336       b # add_newline;
 337       (* process main content: *)
 338       List.iter
 339         (fun n -> n # extension # to_box store b)
 340         (self # node # sub_nodes);
 341       (* now process footnotes *)
 342       store # print_footnotes b;
 343       (* trailer *)
 344       b # add_newline;
 345   end
 346 ;;
 347
 348
 349 class section the_tag =
 350   object (self)
 351     inherit shared
 352
 353     val tag = the_tag
 354
 355     method to_box store b =
 356       let sub_nodes = self # node # sub_nodes in
 357       match sub_nodes with
 358           title_node :: rest ->
 359             b # add_newline;
 360             let w = b # available_width in
 361             let line = String.make (w-1) tag in
 362             b # add_word line;
 363             b # add_newline;
 364             b # add_word (title_node # data);
 365             b # add_newline;
 366             b # add_word line;
 367             b # add_newline;
 368             List.iter
 369               (fun n ->
 370                  n # extension # to_box store b)
 371               rest;
 372         | _ ->
 373             assert false
 374   end
 375 ;;
 376
 377 class sect1 = section '=';;
 378 class sect2 = section '-';;
 379 class sect3 = section ':';;
 380
 381
 382 class p =
 383   object (self)
 384     inherit shared
 385
 386     method to_box store b =
 387       let within_list =
 388         match self # node # parent # node_type with
 389             T_element "li" -> true
 390           | T_element _    -> false
 391           | _ -> assert false
 392       in
 393       if not within_list then
 394         b # add_newline;
 395       let w = b # available_width in
 396       let b' = new box w w in
 397       b' # ignore_space;
 398       List.iter
 399         (fun n -> n # extension # to_box store b')
 400         (self # node # sub_nodes);
 401       b # add_box (b' :> formatted_text);
 402       b # add_newline;
 403   end
 404 ;;
 405
 406
 407 class li =
 408   object (self)
 409     inherit shared
 410
 411     method to_box store b =
 412       b # add_newline;
 413       let w = b # available_width in
 414       let b' = new listitem_box "-" 3 w in
 415       b' # ignore_space;
 416       List.iter
 417         (fun n -> n # extension # to_box store b')
 418         (self # node # sub_nodes);
 419       b # add_box (b' :> formatted_text);
 420   end
 421 ;;
 422
 423
 424 class code =
 425   object (self)
 426     inherit shared
 427
 428     method to_box store b =
 429       b # add_newline;
 430       let w = b # available_width in
 431       let b' = new box w w in
 432       b' # ignore_space;
 433       let data = self # node # data in
 434       (* convert tabs *)
 435       let l = String.length data in
 436       let rec add s i column =
 437         (* this is very ineffective but comprehensive: *)
 438         if i < l then
 439           match data.[i] with
 440               '\t' ->
 441                 let n = 8 - (column mod 8) in
 442                 add (s ^ String.make n ' ') (i+1) (column + n)
 443             | '\n' ->
 444                 b' # add_word s;
 445                 b' # add_newline;
 446                 add "" (i+1) 0
 447             | c ->
 448                 add (s ^ String.make 1 c) (i+1) (column + 1)
 449         else
 450           if s <> "" then begin
 451             b' # add_word s;
 452             b' # add_newline;
 453           end
 454       in
 455       add "" 0 0;
 456       b # add_box (b' :> formatted_text);
 457       b # add_newline;
 458   end
 459 ;;
 460
 461
 462 class br =
 463   object (self)
 464     inherit shared
 465
 466     method to_box store b =
 467       b # add_newline;
 468   end
 469 ;;
 470
 471
 472 class footnote =
 473   object (self)
 474     inherit shared
 475
 476     val mutable footnote_number = 0
 477
 478     method to_box store b =
 479       let number =
 480         store # alloc_footnote (self : #shared :> footnote_printer) in
 481       footnote_number <- number;
 482       b # add_space;
 483       b # add_word ("[" ^ string_of_int number ^ "]");
 484
 485     method footnote_to_box store b =
 486       let w = b # available_width in
 487       let n = "[" ^ string_of_int footnote_number ^ "]" in
 488       let b' = new listitem_box n 6 w in
 489       b' # ignore_space;
 490       List.iter
 491         (fun n -> n # extension # to_box store b')
 492         (self # node # sub_nodes);
 493       b # add_box (b' :> formatted_text);
 494       b # add_newline;
 495       b # add_newline;
 496
 497   end
 498 ;;
 499
 500
 501 class a =
 502   object (self)
 503     inherit shared
 504
 505     val mutable footnote_number = 0
 506     val mutable a_href = ""
 507
 508     method to_box store b =
 509       let href =
 510         match self # node # attribute "href" with
 511             Value v -> "see " ^ v
 512           | Valuelist _ -> assert false
 513           | Implied_value ->
 514               begin match self # node # attribute "readmeref" with
 515                   Value v -> "see file " ^ v
 516                 | Valuelist _ -> assert false
 517                 | Implied_value ->
 518                     ""
 519               end
 520       in
 521       a_href <- href;
 522       List.iter
 523         (fun n -> n # extension # to_box store b)
 524         (self # node # sub_nodes);
 525       if href <> "" then begin
 526         let number =
 527           store # alloc_footnote (self : #shared :> footnote_printer) in
 528         footnote_number <- number;
 529         b # add_space;
 530         b # add_word ("[" ^ string_of_int number ^ "]");
 531       end
 532
 533     method footnote_to_box store b =
 534       if a_href <> "" then begin
 535         let w = b # available_width in
 536         let n = "[" ^ string_of_int footnote_number ^ "]" in
 537         let b' = new listitem_box n 6 w in
 538         b' # ignore_space;
 539         b' # add_word a_href;
 540         b # add_box (b' :> formatted_text);
 541         b # add_newline;
 542         b # add_newline;
 543       end
 544   end
 545 ;;
 546
 547 (**********************************************************************)
 548
 549 open Pxp_yacc
 550
 551 let tag_map =
 552   make_spec_from_alist
 553     ~data_exemplar:(new data_impl (new only_data))
 554     ~default_element_exemplar:(new element_impl (new no_markup))
 555     ~element_alist:
 556        [ "readme",   (new element_impl (new readme));
 557          "sect1",    (new element_impl (new sect1));
 558          "sect2",    (new element_impl (new sect2));
 559          "sect3",    (new element_impl (new sect3));
 560          "title",    (new element_impl (new no_markup));
 561          "p",        (new element_impl (new p));
 562          "br",       (new element_impl (new br));
 563          "code",     (new element_impl (new code));
 564          "em",       (new element_impl (new no_markup));
 565          "ul",       (new element_impl (new no_markup));
 566          "li",       (new element_impl (new li));
 567          "footnote", (new element_impl (new footnote : #shared :> shared));
 568          "a",        (new element_impl (new a : #shared :> shared));
 569        ]
 570     ()
 571 ;;
 572
 573
 574
 575
 576 (* ======================================================================
 577  * History:
 578  *
 579  * $Log$
 580  * Revision 1.1  2000/11/17 09:57:31  lpadovan
 581  * Initial revision
 582  *
 583  * Revision 1.5  2000/08/22 14:34:25  gerd
 584  *      Using make_spec_from_alist instead of make_spec_from_mapping.
 585  *
 586  * Revision 1.4  2000/08/18 21:15:25  gerd
 587  *      Minor updates because of PXP API changes.
 588  *
 589  * Revision 1.3  2000/07/08 17:58:17  gerd
 590  *      Updated because of PXP API changes.
 591  *
 592  * Revision 1.2  2000/06/04 20:25:38  gerd
 593  *      Updates because of renamed PXP modules.
 594  *
 595  * Revision 1.1  1999/08/22 22:29:32  gerd
 596  *      Initial revision.
 597  *
 598  *
 599  *)