Commit 1bc89a55 authored by gerd's avatar gerd

New ~minimization option for the

[write] and [display] methods (user wish).

Fix: [Pxp_document.liquefy] terminates now when invoked
only on a subtree of a document

Cleaned up the code a bit so fewer warnings are emitted in the build.



git-svn-id: https://godirepo.camlcity.org/svn/lib-pxp/trunk@719 dbe99aee-44db-0310-b2b3-d33182c8eb97
parent c09a3eaf
......@@ -50,6 +50,13 @@ for PXP; if you are looking for the stable distribution, please go
<sect1>
<title>Version History</title>
<ul>
<li><p><em>SVN:</em> New ~minimization option for the
[write] and [display] methods (user wish).</p>
<p>Fix: [Pxp_document.liquefy] terminates now when invoked
only on a subtree of a document</p>
<p>Cleaned up the code a bit so fewer warnings are emitted
in the build.</p>
</li>
<li><p><em>1.1.96:</em> Works now for O'Caml 3.09, too.</p>
<p>Fix: The "root element check" is disabled
......
......@@ -238,7 +238,7 @@ class virtual core_parser
let mapping = ref [] in
List.iter
(fun (srcprefix, uri) ->
let normprefix =
let _normprefix =
mng # lookup_or_add_namespace srcprefix uri in
mapping := (srcprefix, uri) :: !mapping;
)
......@@ -947,11 +947,11 @@ declaration():
{{ () }}
| attlistdecl()
{{ () }}
| entid:Decl_entity ws:Ignore Ignore* e:entitydecl(entid)
| entid:Decl_entity ws:Ignore Ignore* _e:entitydecl(entid)
{{ () }}
? {{ match !yy_position with
"ws" -> raise(WF_error("Whitespace is missing after ENTITY"))
| "e" -> raise(WF_error("Name or `%' expected"))
| "_e" -> raise(WF_error("Name or `%' expected"))
| _ -> raise(WF_error("Bad entity declaration"))
}}
| notationdecl()
......@@ -991,7 +991,7 @@ declaration():
raise(WF_error("Restriction of the internal subset: Conditional sections not allowed"));
}}
Ignore*
cond:conditional_section() end_entid:Conditional_end
_cond:conditional_section() end_entid:Conditional_end
{{ (* Check whether Conditional_begin and Conditional_end are in the same
* entity. (This restriction is explained in the file SPECS.)
*)
......@@ -1000,7 +1000,7 @@ declaration():
}}
? {{ match !yy_position with
"end_entid" -> raise(WF_error("`>]>' expected"))
| "cond" -> raise(WF_error("INCLUDE or IGNORE expected"))
| "_cond" -> raise(WF_error("INCLUDE or IGNORE expected"))
| _ -> raise(WF_error("Bad conditional section"))
}}
......@@ -1023,7 +1023,7 @@ conditional_section():
}}
[ parsing_function ] ()
{{ () }}
? {{ raise(WF_error("Bad conditional section")) }}
? {{ ignore(!yy_position); raise(WF_error("Bad conditional section")) }}
included_section():
Conditional_body declaration()*
......@@ -1372,13 +1372,13 @@ atttype():
name: name_or_nametoken()
Ignore*
names: nmtoken_factor()*
rp: Rparen
_rp: Rparen
/* Enumeration */
{{ A_enum(name :: names) }}
? {{ match !yy_position with
"name" -> raise(WF_error("Name expected"))
| "names" -> raise(WF_error("`|' and more names expected, or `)'"))
| "rp" -> raise(WF_error("`|' and more names expected, or `)'"))
| "_rp" -> raise(WF_error("`|' and more names expected, or `)'"))
| _ -> raise(WF_error("Bad enumeration type"))
}}
......@@ -1393,18 +1393,18 @@ never():
notation():
Ignore Ignore*
lp: Lparen
_lp: Lparen
Ignore*
name: Name
Ignore*
names: notation_factor()*
rp: Rparen
_rp: Rparen
{{ A_notation(name :: names) }}
? {{ match !yy_position with
"lp" -> raise(WF_error("`(' expected"))
"_lp" -> raise(WF_error("`(' expected"))
| "name" -> raise(WF_error("Name expected"))
| "names" -> raise(WF_error("`|' and more names expected, or `)'"))
| "rp" -> raise(WF_error("`|' and more names expected, or `)'"))
| "_rp" -> raise(WF_error("`|' and more names expected, or `)'"))
| _ -> raise(WF_error("Bad NOTATION type"))
}}
......@@ -1843,7 +1843,7 @@ start_tag():
let attlist = ref [] in
let attspace = ref true in
}}
ws: Ignore? Ignore*
_ws: Ignore? Ignore*
attribute(attlist,attspace)*
emptiness: start_tag_rangle()
/* Note: it is guaranteed that there is whitespace between Tag_beg and
......
This diff is collapsed.
......@@ -1512,6 +1512,7 @@ class type [ 'ext ] node =
method write :
?prefixes:string list ->
?default:string ->
?minimization:[`AllEmpty | `DeclaredEmpty | `None] ->
Pxp_core_types.output_stream -> Pxp_core_types.encoding -> unit
(* <ID:type-node-write>
* <CALL> obj # [write] ~prefixes stream enc
......@@ -1533,6 +1534,12 @@ class type [ 'ext ] node =
*
* Option [~default]: Specifies the normprefix that becomes the
* default namespace in the output.
*
* Option [~minimization]: How to write out empty elements. [`AllEmpty]
* means that all empty elements are minimized (using the <name/>
* form). [`DeclaredEmpty] minimizes only empty elements that are
* declared as empty in the DTD. [`None] does not minimize at all
* and is the default.
* <DOMAIN> All regular node types (elements, data nodes, comments,
* processing instructions, super root nodes).
* </ID>
......@@ -1540,8 +1547,9 @@ class type [ 'ext ] node =
method display :
?prefixes:string StringMap.t ->
?minimization:[`AllEmpty | `DeclaredEmpty | `None] ->
Pxp_core_types.output_stream -> Pxp_core_types.encoding -> unit
(* <ID:type-node-write>
(* <ID:type-node-display>
* <CALL> obj # [display] ~prefixes stream enc
* <SIG> AUTO
* <DESCR> Write the contents of this node and the subtrees to the passed
......@@ -1560,6 +1568,12 @@ class type [ 'ext ] node =
* effect as pairs of [(prefix,uri)]. The option
* defaults to [] forcing the method to output all necessary prefix
* declarations.
*
* Option [~minimization]: How to write out empty elements. [`AllEmpty]
* means that all empty elements are minimized (using the <name/>
* form). [`DeclaredEmpty] minimizes only empty elements that are
* declared as empty in the DTD. [`None] does not minimize at all
* and is the default.
* <DOMAIN> All regular node types (elements, data nodes, comments,
* processing instructions, super root nodes).
* </ID>
......@@ -2527,6 +2541,7 @@ class [ 'ext ] document :
method write : ?default : string ->
?prefer_dtd_reference : bool ->
?minimization:[`AllEmpty | `DeclaredEmpty | `None] ->
Pxp_core_types.output_stream ->
Pxp_core_types.encoding ->
unit
......@@ -2544,10 +2559,17 @@ class [ 'ext ] document :
* the DTD cannot printed as reference, it is included as text.
* The default is not to try DTD references, i.e. to always include
* the DTD as text.
*
* Option [~minimization]: How to write out empty elements. [`AllEmpty]
* means that all empty elements are minimized (using the <name/>
* form). [`DeclaredEmpty] minimizes only empty elements that are
* declared as empty in the DTD. [`None] does not minimize at all
* and is the default.
*)
method display : ?prefer_dtd_reference : bool ->
?minimization:[`AllEmpty | `DeclaredEmpty | `None] ->
Pxp_core_types.output_stream ->
Pxp_core_types.encoding ->
unit
......@@ -2564,6 +2586,12 @@ class [ 'ext ] document :
* the DTD cannot printed as reference, it is included as text.
* The default is not to try DTD references, i.e. to always include
* the DTD as text.
*
* Option [~minimization]: How to write out empty elements. [`AllEmpty]
* means that all empty elements are minimized (using the <name/>
* form). [`DeclaredEmpty] minimizes only empty elements that are
* declared as empty in the DTD. [`None] does not minimize at all
* and is the default.
*)
method dump : Format.formatter -> unit
......
......@@ -666,7 +666,7 @@ class dtd ?swarner the_warner init_encoding =
try Str_hashtbl.find gen_entities name with Not_found -> assert false
in
if ent # is_ndata then begin
let xid = ent # ext_id in
let _xid = ent # ext_id in
let notation = ent # notation in
try
ignore(self # notation notation)
......
......@@ -500,7 +500,7 @@ class virtual entity the_dtd the_name the_swarner the_warner init_encoding =
cd
(* If there are CRLF sequences in a PI value, normalize them, too *)
| PI(name,value,_) as pi ->
| PI(name,value,_) ->
if v.normalize_newline then
PI(name,
normalize_line_separators v.lfactory value,
......
......@@ -242,7 +242,6 @@ let process_entity
(-1)
lit_root
in
let resolver = mgr # current_resolver in
let init_lexer =
match entry with
`Entry_document _ -> Document
......@@ -288,7 +287,6 @@ let process_expr
cfg mgr eh =
let lit_root = ref "" in
let pobj = new event_parser mgr#dtd cfg eh false (-1) lit_root in
let resolver = mgr # current_resolver in
let en = mgr # current_entity in
begin try
let context = make_context ?first_token mgr in
......@@ -343,7 +341,6 @@ let create_pull_parser
100 (* the number of loops until Interrupt_parsing *)
lit_root
in
let resolver = mgr # current_resolver in
let init_lexer =
match entry with
`Entry_document _ -> Document
......
......@@ -226,7 +226,7 @@ type dtd_style =
]
;;
let wr_dsp do_display default_prefix dtd_style out enc rep_enc get_ev =
let wr_dsp do_display default_prefix dtd_style minimization out enc rep_enc get_ev =
(* do_display: whether [display_events] was called, not [write_events].
* default_prefix: The (optional) default prefix (only [write_events])
*)
......@@ -245,7 +245,7 @@ let wr_dsp do_display default_prefix dtd_style out enc rep_enc get_ev =
* (literal tag name, map of declared prefixes => uris, declared default uri)
*)
let write_start_tag name atts scope_opt =
let write_start_tag name atts scope_opt minimized =
let (_, prefixes, default) =
try Stack.top write_stack
with Stack.Empty -> ("", StringMap.empty, None) in
......@@ -318,10 +318,15 @@ let wr_dsp do_display default_prefix dtd_style out enc rep_enc get_ev =
(* Non-namespace case: *)
Stack.push (name', prefixes, default) write_stack;
);
wms "\n>";
if minimized then (
wms "\n/>";
ignore(Stack.pop write_stack)
)
else
wms "\n>";
in
let display_start_tag name atts scope_opt =
let display_start_tag name atts scope_opt minimized =
let (_, prefixes, default) =
try Stack.top write_stack
with Stack.Empty -> ("", StringMap.empty, None) in
......@@ -430,17 +435,25 @@ let wr_dsp do_display default_prefix dtd_style out enc rep_enc get_ev =
else
write_att "xmlns:" (n,v))
(eff_decl_to_add @ !eff_decl_to_add');
wms "\n>";
Stack.push (name', !prefixes', default) write_stack;
if minimized then
wms "\n/>"
else (
wms "\n>";
Stack.push (name', !prefixes', default) write_stack;
)
| None ->
(* non-namespace case *)
(* Output start tag, and contained attributes: *)
wms ("<" ^ name);
List.iter (write_att "") atts;
wms "\n>";
Stack.push (name, prefixes, default) write_stack;
if minimized then
wms "\n/>"
else (
wms "\n>";
Stack.push (name, prefixes, default) write_stack;
)
in
let write_end_tag() =
......@@ -454,9 +467,13 @@ let wr_dsp do_display default_prefix dtd_style out enc rep_enc get_ev =
wms "\n>"
in
let wr_dsp_event =
function
| E_start_doc(version,dtd) ->
let rec wr_dsp_event ev_opt =
let ev =
match ev_opt with
| Some ev -> ev
| None -> get_ev() in
match ev with
| Some(E_start_doc(version,dtd)) ->
wms ("<?xml version=\"" ^ version ^ "\" ");
wms ("encoding=\"" ^ Netconversion.string_of_encoding enc ^ "\" ");
if dtd # standalone_declaration then
......@@ -473,41 +490,67 @@ let wr_dsp do_display default_prefix dtd_style out enc rep_enc get_ev =
| _ ->
failwith "Pxp_event.write/display: Cannot output DTD as reference"
)
)
| E_end_doc lit_name ->
()
| E_start_tag (name, atts, scope_opt, _) ->
);
wr_dsp_event None
| Some (E_end_doc lit_name) ->
wr_dsp_event None
| Some (E_start_tag (name, atts, scope_opt, _)) ->
let minimized, ev_opt =
match minimization with
| `None ->
(false, None)
| `AllEmpty ->
(* Peek at the next event: *)
let ev' = get_ev() in
let do_minimize =
match ev' with
| Some(E_end_tag (name', _)) ->
name = name'
| _ ->
false in
if do_minimize then
(true, None) (* ==> consume ev'! *)
else
(false, Some ev') in
if do_display then
display_start_tag name atts scope_opt
display_start_tag name atts scope_opt minimized
else
write_start_tag name atts scope_opt
| E_end_tag (_, _) ->
write_end_tag()
| E_char_data data ->
write_data_string ~from_enc:rep_enc ~to_enc:enc out data
| E_pinstr (target, value, ent_id) ->
write_start_tag name atts scope_opt minimized;
wr_dsp_event ev_opt
| Some (E_end_tag (_, _)) ->
write_end_tag();
wr_dsp_event None
| Some (E_char_data data) ->
write_data_string ~from_enc:rep_enc ~to_enc:enc out data;
wr_dsp_event None
| Some (E_pinstr (target, value, ent_id)) ->
wms "<? "; wms target; wms " "; wms value; wms "?>";
| E_pinstr_member (target, value, ent_id) ->
wr_dsp_event None
| Some (E_pinstr_member (target, value, ent_id)) ->
wms "<? "; wms target; wms " "; wms value; wms "?>";
| E_comment data ->
wr_dsp_event None
| Some (E_comment data) ->
wms "<!--"; wms data; wms "-->";
| E_start_super ->
()
| E_end_super ->
()
| E_position (_,_,_) ->
()
| E_error exn ->
wr_dsp_event None
| Some E_start_super ->
wr_dsp_event None
| Some E_end_super ->
wr_dsp_event None
| Some (E_position (_,_,_)) ->
wr_dsp_event None
| Some (E_error exn) ->
failwith "Pxp_event.write/display: Cannot output E_error event"
| E_end_of_stream ->
| Some E_end_of_stream ->
wr_dsp_event None
| None ->
()
in
iter wr_dsp_event get_ev
wr_dsp_event None
;;
let write_events ?default ?(dtd_style = `Include) =
wr_dsp false default dtd_style ;;
let display_events ?(dtd_style = `Include) =
wr_dsp true None dtd_style ;;
let write_events ?default ?(dtd_style = `Include) ?(minimization=`None) =
wr_dsp false default dtd_style minimization ;;
let display_events ?(dtd_style = `Include) ?(minimization=`None) =
wr_dsp true None dtd_style minimization ;;
......@@ -108,6 +108,7 @@ type dtd_style =
val write_events :
?default:string -> (* Default: none *)
?dtd_style:dtd_style -> (* Default: `Include *)
?minimization:[`AllEmpty | `None] -> (* Default: `None *)
output_stream ->
encoding ->
rep_encoding ->
......@@ -128,10 +129,15 @@ val write_events :
* in the internal subset
* - `Reference: The DOCTYPE clause is written as a reference to an
* external DTD
*
* Option [~minimization]: How to write out empty elements. [`AllEmpty]
* means that all empty elements are minimized (using the <name/>
* form). [`None] does not minimize at all and is the default.
*)
val display_events :
?dtd_style:dtd_style -> (* Default: `Include *)
?minimization:[`AllEmpty | `None] -> (* Default: `None *)
output_stream ->
encoding ->
rep_encoding ->
......
......@@ -623,17 +623,17 @@ and check_node_expr_as_string : ast_node -> ast_string =
(**********************************************************************)
(* Code generator for tree expressions *)
let mkloc ((p1_line,p1_line_start,p1_pos) as p1)
((p2_line,p2_line_start,p2_pos) as p2) =
let mkloc ((_p1_line,_p1_line_start,p1_pos))
((_p2_line,_p2_line_start,p2_pos)) =
(* Differs in O'Caml 3.07 and 3.08 *)
IFDEF OCAML_NEW_LOC THEN
let l1 = { Lexing.pos_fname = "";
Lexing.pos_lnum = p1_line;
Lexing.pos_bol = p1_line_start;
Lexing.pos_lnum = _p1_line;
Lexing.pos_bol = _p1_line_start;
Lexing.pos_cnum = p1_pos } in
let l2 = { Lexing.pos_fname = "";
Lexing.pos_lnum = p2_line;
Lexing.pos_bol = p2_line_start;
Lexing.pos_lnum = _p2_line;
Lexing.pos_bol = _p2_line_start;
Lexing.pos_cnum = p2_pos } in
(l1,l2)
ELSE
......@@ -984,11 +984,11 @@ let generate_event_generator
ast_node_list -> (ann * MLast.expr) list = (
function
(`Nodes l, p1, p2) ->
let loc = mkloc p1 p2 in
(* let loc = mkloc p1 p2 in *)
let l' = List.map (generate_for_node_expr nsmode) l in
List.flatten l'
| (`Concat l, p1, p2) ->
let loc = mkloc p1 p2 in
(* let loc = mkloc p1 p2 in *)
let l' = List.map (generate_for_nodelist_expr nsmode) l in
List.flatten l'
| (`Ident name, p1, p2) ->
......
......@@ -15,7 +15,7 @@ rule scan_file = parse
| "<" [' ' '\t' '\r' '\n']* ">"
{ Type
}
| [ 'a'-'z' ] [ 'a'-'z' 'A'-'Z' '0'-'9' '_' ]*
| [ '_' 'a'-'z' ] [ 'a'-'z' 'A'-'Z' '0'-'9' '_' ]*
{ let s = Lexing.lexeme lexbuf in
Lname s
}
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment