(*
* <COPYRIGHT>
* Copyright 2006 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_init_expr.ml,v 3.2 2006-03-08 16:05:02 stolpmann Exp $ *)
open Wd_types
open Wd_util
open Wd_brexpr
open Pxp_types
let parse_init_expr enc ev_list : init_expr =
let rec parse_value_expr ev_stream =
match ev_stream with parser
| [< 'E_start_tag("ui:string-value",_,_,_);
s_opt = parse_char_data_opt;
'E_end_tag("ui:string-value",_)
>] ->
let expr =
match s_opt with
| Some s ->
Wd_brexpr.parse_expr_string
~enable_param:false ~enable_brexpr:true enc s
| None ->
[] in
`String_iexpr expr
| [< 'E_start_tag("ui:enum-value",_,_,_);
items = parse_enum_items;
'E_end_tag("ui:enum-value",_)
>] ->
`Enum_iexpr items
| [< 'E_start_tag("ui:dyn-enum-value",_,_,_);
items = parse_dyn_enum_items;
'E_end_tag("ui:dyn-enum-value",_)
>] ->
`Dyn_enum_iexpr items
| [< 'E_start_tag("ui:any-value",_,_,_);
'E_char_data s;
'E_end_tag("ui:any-value",_);
>] ->
let expr_l = Wd_brexpr.parse_expr_string
~enable_param:false ~enable_brexpr:true enc s in
( match expr_l with
| [ (#expr as expr, _) ] ->
`Value_iexpr expr
| [ (`Expr_oe _, _) ] ->
raise(Formal_user_error("The element ui:any-value must not specify an output encoding"))
| _ ->
raise(Formal_user_error("The element ui:any-value must exactly contain one bracket expression $[...]"))
)
| [< 'E_start_tag("ui:matrix-value",_,_,_);
head = parse_matrix_head;
body = parse_matrix_body head;
'E_end_tag("ui:matrix-value",_);
>] ->
`Matrix_iexpr(head, Array.of_list body)
| [< 'E_start_tag("ui:map-value",atts,_,_);
inner_exprs = parse_value_exprs;
'E_end_tag("ui:map-value",_)
>] ->
let mapping_expr =
try
List.assoc "mapping" atts
with
| Not_found ->
raise(Formal_user_error("Missing attribute 'mapping' in ui:map-value")) in
let mapping_l =
Wd_brexpr.parse_expr_string
~enable_param:false ~enable_brexpr:true enc mapping_expr in
( match mapping_l with
| [ (#expr as expr, _) ] ->
`Map_iexpr (expr, inner_exprs)
| [ (`Expr_oe _, _) ] ->
raise(Formal_user_error("The attribute 'mapping' of ui:map-value must not specify an output encoding"))
| _ ->
raise(Formal_user_error("The attribute 'mapping' of ui:map-value must exactly contain one bracket expression $[...]"))
)
| [< 'E_start_tag("ui:ds-value",atts,_,_);
s_opt = parse_char_data_opt;
'E_end_tag("ui:ds-value",_);
>] ->
let ds =
try
List.assoc "ds" atts
with
| Not_found ->
raise(Formal_user_error("Missing attribute 'ds' in ui:ds-value")) in
let expr =
match s_opt with
| Some s ->
Wd_brexpr.parse_expr_string
~enable_param:false ~enable_brexpr:true enc s
| None ->
[] in
`Dsrc_iexpr(ds, expr)
| [< 'E_start_tag("ui:alist-value",_,_,_);
items = parse_alist_items;
'E_end_tag("ui:alist-value",_)
>] ->
`Alist_iexpr items
and parse_char_data_opt ev_stream =
match ev_stream with parser
| [< 'E_char_data s >] -> Some s
| [< >] -> None
and parse_enum_items ev_stream =
match ev_stream with parser
| [< 'E_start_tag("ui:enum-item", atts, _, _);
'E_end_tag("ui:enum-item",_);
items = parse_enum_items;
>] ->
let int_expr =
try List.assoc "internal" atts
with
| Not_found ->
raise(Formal_user_error("The attribute 'internal' is required for ui:enum-item")) in
let int =
Wd_brexpr.parse_expr_string
~enable_param:false ~enable_brexpr:true enc int_expr in
int :: items
| [< >] ->
[]
and parse_dyn_enum_items ev_stream =
match ev_stream with parser
| [< 'E_start_tag("ui:dyn-enum-item", atts, _, _);
'E_end_tag("ui:dyn-enum-item",_);
items = parse_dyn_enum_items;
>] ->
let int_expr =
try List.assoc "internal" atts
with
| Not_found ->
raise(Formal_user_error("The attribute 'internal' is required for ui:dyn-enum-item")) in
let int =
Wd_brexpr.parse_expr_string
~enable_param:false ~enable_brexpr:true enc int_expr in
let ext =
try
Wd_brexpr.parse_expr_string
~enable_param:false ~enable_brexpr:true enc
(List.assoc "external" atts)
with
| Not_found -> int in
(int, ext) :: items
| [< >] ->
[]
and parse_alist_items ev_stream =
match ev_stream with parser
| [< 'E_start_tag("ui:alist-item", atts, _, _);
inner_expr = parse_value_expr;
'E_end_tag("ui:alist-item",_);
items = parse_alist_items;
>] ->
let index_expr =
try List.assoc "index" atts
with
| Not_found ->
raise(Formal_user_error("The attribute 'index' is required for ui:alist-item")) in
let index =
Wd_brexpr.parse_expr_string
~enable_param:false ~enable_brexpr:true enc index_expr in
(index, inner_expr) :: items
| [< >] ->
[]
and parse_matrix_head ev_stream =
let columns = parse_matrix_head_1 ev_stream in
let dup_columns = duplicates columns in
if dup_columns <> [] then
raise(Formal_user_error("Duplicate columns (in ui:matrix-head): " ^
String.concat ", " dup_columns));
Array.of_list columns
and parse_matrix_head_1 ev_stream =
match ev_stream with parser
| [< 'E_start_tag("ui:matrix-head",atts,_,_);
'E_end_tag("ui:matrix-head",_);
head = parse_matrix_head_1
>] ->
let column =
try List.assoc "column" atts
with
| Not_found ->
raise(Formal_user_error("The attribute 'column' is required for ui:matrix-head")) in
column :: head
| [< >] ->
[]
and parse_matrix_body head ev_stream =
match ev_stream with parser
| [< 'E_start_tag("ui:matrix-row",_,_,_);
row = parse_matrix_row;
'E_end_tag("ui:matrix-row",_);
matrix = parse_matrix_body head
>] ->
let col_names = List.map fst row in
let dup_col_names = duplicates col_names in
if dup_col_names <> [] then
raise(Formal_user_error("Duplicate columns (in ui:matrix-cell): " ^
String.concat ", " dup_col_names));
let mrow =
Array.init
(Array.length head)
(fun k ->
let col = head.(k) in
let cell =
try List.assoc col row
with
| Not_found ->
raise(Formal_user_error("Missing column in row: " ^ col)) in
cell
) in
mrow :: matrix
| [< >] ->
[]
and parse_matrix_row ev_stream =
match ev_stream with parser
| [< 'E_start_tag("ui:matrix-cell", atts, _, _);
'E_char_data s;
'E_end_tag("ui:matrix-cell",_);
row = parse_matrix_row;
>] ->
let expr = Wd_brexpr.parse_expr_string
~enable_param:false ~enable_brexpr:true enc s in
let column =
try List.assoc "column" atts
with
| Not_found ->
raise(Formal_user_error("The attribute 'column' is required for ui:matrix-cell")) in
(column, expr) :: row
| [< >] ->
[]
and parse_value_exprs ev_stream =
match ev_stream with parser
| [< expr = parse_value_expr;
exprs = parse_value_exprs;
>] -> expr :: exprs
| [< >] -> []
in
try
( let ev_stream = Stream.of_list ev_list in
match ev_stream with parser
| [< expr = parse_value_expr; 'E_end_of_stream >] ->
expr
)
with
| Stream.Failure
| Stream.Error "" ->
raise(Formal_user_error "Syntax error in dialog initializer")
| Stream.Error msg ->
raise(Formal_user_error("Syntax error in dialog initializer: " ^ msg))
;;
let eval_init_expr dlg iexpr =
let rec eval iexpr =
match iexpr with
| `String_iexpr sexpr ->
String_value(Wd_brexpr_eval.eval_string_expr dlg sexpr)
| `Enum_iexpr items ->
Enum_value
(List.map
(fun sexpr ->
Wd_brexpr_eval.eval_string_expr dlg sexpr)
items)
| `Dyn_enum_iexpr items ->
Dyn_enum_value
(List.map
(fun (sexpr1, sexpr2) ->
let s1 = Wd_brexpr_eval.eval_string_expr dlg sexpr1 in
let s2 = Wd_brexpr_eval.eval_string_expr dlg sexpr2 in
(s1,s2) )
items
)
| `Alist_iexpr items ->
Alist_value
(List.map
(fun (sexpr, iexpr) ->
let s = Wd_brexpr_eval.eval_string_expr dlg sexpr in
let v = eval iexpr in
( match v with
| Alist_value _ ->
raise(Eval_error_noloc("Alists must not contain inner alists"))
| _ -> ()
);
(s, v) )
items )
| `Matrix_iexpr (head, rows) ->
Matrix_value
(head,
Array.map
(fun row ->
Array.map
(fun sexpr ->
Wd_brexpr_eval.eval_string_expr dlg sexpr)
row)
rows)
| `Value_iexpr any_expr ->
Wd_brexpr_eval.eval_expr dlg any_expr
| `Map_iexpr (fun_expr, iexprs) ->
let mapping_v = Wd_brexpr_eval.eval_expr dlg fun_expr in
let argument_v_l = List.map eval iexprs in
let argument_v_a = Array.of_list argument_v_l in
let arg_n = List.length argument_v_l in
let arg_names =
Array.init arg_n (fun k -> "arg_" ^ string_of_int k) in
let arg_name_vals =
Array.mapi (fun k name -> (name, lazy argument_v_a.(k)) ) arg_names in
Wd_brexpr_eval.eval_expr
~local_bindings:( [ "mapping", lazy mapping_v ] @
Array.to_list arg_name_vals )
dlg
(`Expr_apply(`Expr_var "mapping",
Array.to_list
(Array.map (fun n -> `Expr_var n) arg_names)))
| `Dsrc_iexpr (provider_name, sexpr) ->
let provider =
try dlg#application#data_source provider_name
with
| Not_found ->
raise(Eval_error_noloc("Undefined data source: " ^
provider_name)) in
let provider_expr =
Wd_brexpr_eval.eval_string_expr dlg sexpr in
let table =
provider # retrieve provider_expr in
Table_value table
in
eval iexpr
;;
