(*
* <COPYRIGHT>
* Copyright 2002 Joachim Schrod Network and Publication Consultance GmbH, Gerd Stolpmann
*
* <GPL>
* This file is part of WDialog.
*
* WDialog is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* WDialog is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with WDialog; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
* </>
*)
(* $Id: wd_templrep.ml,v 3.7 2006-03-08 00:56:45 stolpmann Exp $
* ----------------------------------------------------------------------
*
*)
open Pxp_types
open Pxp_document
open Pxp_dtd
open Wd_types
open Wd_brexpr
module D = Wd_dictionary
(* The data type of a tree with placeholders (parameters). The placeholders
* may occur in data nodes, or in attribute values.
*)
type 'ext tree =
Element of 'ext tree_element (* <x> ... </x> *)
| Data of 'ext tree_data (* arbitrary text *)
| Param of (string * string list) (* ${paramname/enc1/enc2/...} *)
| Expr of (expr_oe * string * 'ext node * (string*int*int))
(* for $[expr/enc1/enc2/...]:
* (expr, expr_as_string, parent_node, parent_node_pos)
*)
constraint 'ext = 'ext node #extension
and 'ext tree_element =
{ el_name : string; (* The name of the element *)
el_attributes : (string * att_expr_value) list;
(* (name, value) list. The values are sequences of normal text and
* parameters.
* E.g. att="a $x y" is repesented as
* [ "att", [ Att_verb "a "; Att_param "x"; Att_verb " y" ]]
*
* Note:
* Attributes with an empty string as value are represented as
* [ Att_verb "" ]. Attributes with implied value are represented
* as [].
*)
el_unsplit_attributes : (string * att_value) list;
(* The original attributes. *)
el_have_placeholders_in_atts : bool;
(* Whether there are parameters in attribute values or not *)
el_node : 'ext node;
(* A reference to the original XML node *)
el_subtrees : 'ext tree list; (* The trees within this element *)
}
and 'ext tree_data =
{ dt_value : string; (* The string *)
dt_node : 'ext node; (* Reference to the original node *)
dt_clonable : bool;
(* true if dt_value = dt_node # data, i.e. if there is not any
* '$' sequence in the data node, and the node need not to be
* splitted up.
* There is an important optimization basing on this information.
*)
}
and att_expr_value =
| Att_expr_value of expr_string
| Att_expr_implied
;;
type 'ext t =
{ contents : 'ext tree list;
app : application_type;
template_name : string; (* Only used for error messages *)
mk_uiencode : unit -> 'ext node;
}
;;
type 'ext param =
{ param_tree : 'ext Pxp_document.node;
param_text : string Lazy.t;
}
let get_parameters t =
let params = ref D.empty in
let add p =
params := D.add p () !params in
let rec scan_tree =
function
Element e ->
List.iter
(function
| (_, Att_expr_implied) ->
()
| (_, Att_expr_value e) ->
let pl = params_in_expr_string e in
List.iter add pl
)
e.el_attributes;
List.iter scan_tree e.el_subtrees;
| Param (p,_) ->
add p
| Expr (e, _, _, _) ->
let pl = params_in_expr e in
List.iter add pl
| _ ->
()
in
List.iter scan_tree t.contents;
!params
;;
let scan_attributes n =
(* Transform the attribute list of 'n' into a list like el_attributes. *)
let enc = n # encoding in
let atts = n # attributes in
let atts' =
List.map
(fun (att_name, att_value) ->
match att_value with
Value s ->
let v = parse_expr_string
~enable_param:true ~enable_brexpr:true enc s in
att_name, (Att_expr_value v)
| Valuelist sl ->
let s = String.concat " " sl in
let v = parse_expr_string
~enable_param:true ~enable_brexpr:true enc s in
att_name, (Att_expr_value v)
| Implied_value ->
att_name, Att_expr_implied
)
atts
in
atts'
;;
let placeholder_exists l =
(* return 'true' if there are placeholders in l, i.e. non-constant text *)
List.exists
(function
| (n,Att_expr_implied) ->
false
| (n,Att_expr_value v) ->
List.exists
(function
| (`Literal _, _) -> false
| _ -> true)
v
)
l
;;
let rec find_parent_element n =
match n # node_type with
T_element _ -> n
| _ -> find_parent_element (n#parent)
;;
let rec prepare_tree_with_parameters ~mk_uiencode name app nl =
(* We need the 'treelist', the 'tree' type representation of the
* prepared XML tree 'nl' (=nodelist).
* The other components 'app' and 'template_name' are already known
* and can be entered directly.
*)
let treelist = List.flatten (List.map scan_tree nl) in
{ contents = treelist;
app = app;
template_name = name;
mk_uiencode = mk_uiencode;
}
and scan_tree n =
(* Transform the node tree 'n' into the corresponding 'tree list' value *)
let enc = n # encoding in
match n # node_type with
T_element element_name ->
(* An element is simply converted to the corresponding representation.
* Only the attributes have to be processed, but that is done
* separately in the function scan_attributes.
*)
let scanned_atts = scan_attributes n in
[ Element
{ el_name = element_name;
el_attributes = scanned_atts;
el_unsplit_attributes = n # attributes;
el_have_placeholders_in_atts = placeholder_exists scanned_atts;
el_node = n;
el_subtrees =
List.flatten
(List.map scan_tree (n # sub_nodes));
}
]
| T_data ->
(* A data node may contain parameters. So we must apply a regexp
* on the data string to split the node up.
*)
let l =
parse_expr_string
~enable_param:true ~enable_brexpr:true enc n#data in
List.map
(function
| (`Literal s, _) ->
Data
{ dt_value = s;
dt_node = n;
dt_clonable = (List.length l = 1);
}
| (`Expr_strconst s, _) ->
Data
{ dt_value = s;
dt_node = n;
dt_clonable = false;
}
| (`Expr_param(name,enclist), _) ->
Param(name,enclist)
| (#expr_oe as e, in_s) ->
let pos =
try
(find_parent_element n) # position
with Not_found -> assert false in
Expr(e,in_s,n,pos)
)
l
| _ -> assert false
(* other types of node cannot occur ! *)
;;
let instantiate dlg r params container =
let dtd = r.app#dtd in
let rec lookup key l =
(* Look up the parameter 'key' in the parameter dict list 'l', or
* raise Not_found.
*)
match l with
[] -> raise Not_found
| x :: l' ->
try
Wd_dictionary.find key x
with
Not_found -> lookup key l'
in
let transform_to_uiencode n enclist =
(* Wrap the node tree [n] into <ui:encode enc="ENCLIST">...</ui:encode> *)
if enclist = [] then
n
else
let n' = r.mk_uiencode() in
n' # set_attributes [ "enc", Valuelist enclist ];
n' # set_nodes [n];
n'
in
let lookup_text p =
(* Return the text string for parameter 'p' or raise a Runtime_error,
* if 'p' does not exist
*)
try
Lazy.force (lookup p params).param_text
with
Not_found ->
raise (Instantiation_error
(r.template_name ^
": Nothing to instantiate for template parameter `$" ^ p ^ "'"))
in
let lookup_tree p =
(* Return the XML tree for parameter 'p' or raise a Runtime_error,
* if 'p' does not exist
*)
try
(lookup p params).param_tree
with
Not_found ->
raise (Instantiation_error
(r.template_name ^
": Nothing to instantiate for template parameter `$" ^ p ^ "'"))
in
let raise_insterr_with_loc (entity,line,col) msg expr_str =
if line >= 0 then
raise
(Instantiation_error
("In entity " ^ entity ^ ", near line " ^ string_of_int line ^
", position " ^ string_of_int col ^ ", within the expression "
^ expr_str ^ ": " ^ msg))
else
raise
(Instantiation_error
("In the expression " ^ expr_str ^ ": " ^ msg))
in
let eval_expr_prot (entity,line,col) expr expr_str =
let subst (p_name,enclist) =
Wd_brexpr_eval.apply_oe r.app (lookup_text p_name) enclist in
try
Wd_brexpr_eval.eval_expr_oe dlg (subst_expr_params ~subst expr)
with
| (Instantiation_error msg as e) -> (* From subst_expr_params *)
raise_insterr_with_loc (entity,line,col) msg expr_str
| Eval_error_noloc msg -> (* From eval_expr *)
raise_insterr_with_loc (entity,line,col) msg expr_str
in
let rec inst_attributes pos l =
(* Instantiate the attributes in the list 'l', an el_attributes-like
* list. Returns the attributes in a form that can be passed as
* argument to the method create_element.
*)
match l with
[] -> []
| (n, Att_expr_implied) :: l' ->
(* Implied value: leave this out *)
inst_attributes pos l'
| (n, Att_expr_value v) :: l' ->
(* Normal value *)
let v' =
String.concat
""
(List.map
(function
| (`Literal s, _) -> s
| (`Expr_param (p,enclist), _) ->
Wd_brexpr_eval.apply_oe r.app (lookup_text p) enclist
| ((#expr_oe as e), in_s) ->
eval_expr_prot pos e in_s
)
v
)
in
(n, v') :: inst_attributes pos l'
in
let rec inst tree =
(* Instantiates the 'tree' by descending recursively into the tree,
* calling the right instantiation function for every node,
* and creating a new XML tree with the same structure as 'tree'.
* The XML tree is returned.
*)
match tree with
Element el ->
(* If there are no attributes with parameters, some speedup is
* possible.
*)
if el.el_have_placeholders_in_atts then begin
(* The slower but general case. *)
let pos = el.el_node # position in
let inst_atts = inst_attributes pos el.el_attributes in
let c = el.el_node # create_element
dtd (T_element el.el_name) inst_atts in
c # set_nodes (List.map inst (el.el_subtrees));
c
end
else begin
(* The simple and fast case *)
let c = el.el_node # orphaned_flat_clone in
c # quick_set_attributes (el.el_unsplit_attributes);
c # set_nodes (List.map inst (el.el_subtrees));
c
end
| Data dt ->
if dt.dt_clonable then
(* Optimization: We can simply clone dt_node to get the new
* node. This is much faster because:
* - The clone and the original share the data string; it is
* not copied
* - The 'data_node' class (in Parse) does some optimizations, too.
* Especially the HTML-escaped version of the data string is
* precomputed, and this second string can be shared, too.
*)
dt.dt_node # orphaned_flat_clone
else
(* The general case: Create a new data node with contents
* dt_value.
*)
dt.dt_node # create_data dtd dt.dt_value
| Param (p,enclist) ->
let replacement = lookup_tree p in
transform_to_uiencode replacement#orphaned_clone enclist
| Expr (expr,expr_str,dt_node,pos) ->
let value = eval_expr_prot pos expr expr_str in
dt_node # create_data dtd value
in
let nodes = List.map inst r.contents in
container # set_nodes nodes
;;
(* ======================================================================
* History:
*
* $Log: wd_templrep.ml,v $
* Revision 3.7 2006-03-08 00:56:45 stolpmann
* Addition of Table_value, Matrix_value and Function_value.
*
* New parser for initial expressions. It is now possible to
* use $[...] in variable initializers.
*
* Extended bracket expressions: functions, let expressions,
* word literals, matrix literals.
*
* New type for message catalogs, although not yet implemented.
*
* Revision 3.6 2005/06/11 14:24:14 stolpmann
* Extension of bracket expressions: many new functions.
* Functions in bracket expressions may now lazily evaluate their arguments.
* ui:if and ui:ifvar may refer to any functions defined for bracket
* expressions.
* New: ui:ifexpr
* Parsing of bracket expressions is now done with ulex. Private interfaces
* of PXP are no longer used for this purpose.
* Serialization has been rewritten, and it is now safe.
* Fix: In ui:context there may now be macro references at any location.
* Also documented all these changes.
*
* Revision 3.5 2004/08/01 18:31:35 stolpmann
* Updated PXP lexer code to SVN version of PXP.
* Note: This is a temporary solution, not for release!
*
* Revision 3.4 2002/10/20 19:39:17 stolpmann
* New feature: The brackets $[...] can contain expressions,
* not only variables
*
* Revision 3.3 2002/02/26 23:56:35 stolpmann
* Fix: $[var] in attributes is no longer optimized away in
* some cases
*
* Revision 3.2 2002/02/14 16:15:21 stolpmann
* Added copyright notice.
*
* Revision 3.1 2002/02/12 20:29:20 stolpmann
* Initial release at sourceforge.
*
* Revision 1.8 2002/01/30 15:13:33 gerd
* New: The notations ${name/enc1/...} and $[name/enc1/...] are
* recognized and handled properly.
*
* Revision 1.7 2002/01/27 19:13:15 gerd
* New: [get_parameters]
*
* Revision 1.6 2002/01/26 22:38:26 gerd
* Changed the type for passing parameters to templates. It is
* now syntax_tree dict instead of a simple list. Furthermore, the
* method [instantiate] no longer returns the new context. The new element
* ui:context creates the new contexts now.
*
* Revision 1.5 2002/01/24 23:34:33 gerd
* The function [instantiate] raises [Instantiation_error] on
* errors.
*
* Revision 1.4 2002/01/14 15:03:24 gerd
* Major change: Typing has been completely revised, and almost
* every tiny thing has now a new type. Also renamed a lot.
*
* Revision 1.3 2001/05/21 12:52:27 gerd
* Added a type constraint due to stricter type checking in
* O'Caml 3.01
*
* Revision 1.2 2000/09/21 15:12:34 gerd
* Updated for O'Caml 3 and PXP
*
* Revision 1.1 2000/05/08 10:36:37 gerd
* Initial revision.
*
*
*)
