(*
* <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_brexpr_eval.ml,v 3.2 2006-03-08 16:05:02 stolpmann Exp $ *)
open Wd_types
open Wd_brexpr
open Wd_util
let rec apply_oe app s enclist =
(* Apply the encodings [enclist] to [s], one after the other *)
match enclist with
[] -> s
| enc :: enclist' ->
let f = app#output_encoding enc in
apply_oe app (f s) enclist'
;;
let extract_head m =
match m with
| [] ->
[| |]
| first_row :: _ ->
let h = List.map fst first_row in
let h_dups = duplicates h in
if h_dups <> [] then
failwith ("Matrix has duplicate columns: " ^
String.concat ", " h_dups);
Array.of_list h
;;
let eval_expr ?(local_bindings = []) (dlg : dialog_type) (e : expr) =
let rec eval var_bindings (e : expr) =
match e with
| `Expr_var var_name ->
(* If bound locally, return the local value, else the value of the
* dialog variable
*)
( try
Lazy.force(Wd_dictionary.find var_name var_bindings)
with
| Not_found ->
dlg # variable var_name
)
| `Expr_strconst s ->
String_value s
| `Expr_matrix m ->
let head = extract_head m in
(* Possible optimization: Extract only once, not in every eval *)
let rows =
Array.map
(fun row ->
Array.mapi
(fun k (col_name, cell) ->
if k >= Array.length head || head.(k) <> col_name then
failwith "Badly formed matrix: column mismatch";
( match eval var_bindings cell with
| String_value s -> s
| _ ->
failwith "Matrices can only contain strings"
)
)
(Array.of_list row)
)
(Array.of_list m) in
Matrix_value(head, rows)
| `Expr_apply ( `Expr_fun_name "type", args) ->
(* CHECK: We ignore here that there may be locally bound
* variables!
*)
( match args with
[ `Expr_var var_name ] ->
let d = dlg # declaration # variable var_name in
( match d.var_type with
String_type -> String_value "string"
| Enum_type e -> String_value e.enum_name
| Dialog_type -> String_value "dialog"
| Dyn_enum_type -> String_value "dynamic-enumerator"
| Matrix_type -> String_value "matrix"
| Table_type -> String_value "table"
)
| _ ->
failwith "Function `type' must be applied to a variable"
)
| `Expr_apply ( `Expr_fun_name ("is_associative" | "is-associative"), args) ->
(* CHECK: We ignore here that there may be locally bound
* variables!
*)
( match args with
[ `Expr_var var_name ] ->
let d = dlg # declaration # variable var_name in
String_value(if d.var_associative then "yes" else "no")
| _ ->
failwith "Function `is_associative' must be applied to a variable"
)
| `Expr_apply ( `Expr_fun_name "default", args) ->
(* CHECK: We ignore here that there may be locally bound
* variables!
*)
( match args with
[ `Expr_var var_name ] ->
dlg # initial_variable_value var_name
| _ ->
failwith "Function `default' must be applied to a variable"
)
| `Expr_apply ( `Expr_fun_name "enum", args) ->
( match args with
[ `Expr_var var_name ] ->
( try
let e = dlg # declaration # enumeration var_name in
Dyn_enum_value e.enum_definition
with
Not_found ->
failwith("Function `enum': enumeration not found: " ^ var_name)
)
| _ ->
failwith "Function `enum': bad usage"
)
| `Expr_apply ( `Expr_fun_name "words", args) ->
let s =
String.concat " "
(List.map
(function
| `Expr_var var_name ->
var_name
| _ ->
failwith "Function `words': bad usage"
)
args) in
String_value s
| `Expr_apply ( `Expr_fun_name "m", args) ->
let s =
match args with
| [ `Expr_var var_name ] ->
var_name
| _ ->
failwith "Function `m': bad usage"
in
let fn =
try dlg # application # var_function "cat-translate"
with Not_found -> failwith "function cat-translate not found" in
fn dlg [ String_value s ]
| `Expr_apply ( `Expr_fun_name fn_name, args) ->
let args' = List.map (fun arg -> lazy(eval var_bindings arg)) args in
let fn =
try
let fn_val =
Lazy.force(Wd_dictionary.find fn_name var_bindings) in
( match fn_val with
| Function_value fn -> fn
| _ ->
failwith("Only functions can be applied to arguments")
)
with
| Not_found ->
( try
dlg # application # lazy_var_function fn_name
with
Not_found ->
failwith("No such function: " ^ fn_name)
)
in
fn dlg args'
| `Expr_apply ( (#expr as fn_expr), args ) ->
let fn_val = eval var_bindings fn_expr in
(* always eager eval here *)
( match fn_val with
| Function_value fn ->
let args' =
List.map (fun arg -> lazy(eval var_bindings arg)) args in
fn dlg args'
| _ ->
failwith "Only functions can be applied to arguments"
)
| `Expr_fun (var_names, bound_expr) ->
let var_dups = duplicates var_names in
if var_dups <> [] then
failwith("Duplicate variables in function definition: " ^
String.concat ", " var_dups);
let n_names = List.length var_names in
let fn dlg args =
if List.length args <> n_names then
failwith "Called function with wrong number of arguments";
let args' = List.combine var_names args in
let var_bindings' =
List.fold_left
(fun b (var_name, arg) ->
Wd_dictionary.add var_name arg b
)
var_bindings
args' in
eval var_bindings' bound_expr
in
Function_value fn
| `Expr_let (let_bindings, bound_expr) ->
let let_names = List.map fst let_bindings in
let let_dups = duplicates let_names in
if let_dups <> [] then
failwith("Duplicate variables in 'let' binding: " ^
String.concat ", " let_dups);
let var_bindings' =
List.fold_left
(fun b (let_name, let_expr) ->
let arg = lazy (eval var_bindings let_expr) in
Wd_dictionary.add let_name arg b
)
var_bindings
let_bindings in
eval var_bindings' bound_expr
| `Expr_param(_,_) ->
assert false
in
try
eval (Wd_dictionary.of_alist local_bindings) e
with
| Failure msg ->
raise(Eval_error_noloc msg)
| No_such_variable msg ->
raise(Eval_error_noloc("No such variable: " ^ msg))
;;
let eval_expr_s dlg e =
let v = eval_expr dlg e in
( match v with
| String_value s -> s
| _ ->
failwith("The final result of an expression must be a string")
)
;;
let eval_expr_oe dlg expr =
match expr with
| `Expr_oe (e, oelist) ->
let s = eval_expr_s dlg e in
apply_oe dlg#application s oelist
| #expr as e ->
eval_expr_s dlg e
;;
let eval_string_expr dlg str_expr =
String.concat ""
(List.map
(fun (item, s) ->
try
( match item with
| `Literal s -> s
| (#expr_oe as e) -> eval_expr_oe dlg e
)
with
| Eval_error_noloc msg ->
raise(Eval_error("In expression " ^ s ^ ": " ^ msg))
)
str_expr)
;;
