(*
* <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_extension.ml,v 3.4 2002-09-25 00:19:20 stolpmann Exp $
* ----------------------------------------------------------------------
*
*)
open Pcaml;;
(* Syntax extension:
*
* You can now write
*
* class name ... = interactive object ... end
*
* The new keyword "interactive" enables the following special features:
*
* - Methods with names "prepare_*" are collected, and a dispatcher method
* "prepare_page" is generated and added
* - Methods with names "handle_*" are collected, and a dispatcher method
* "handle" is generated and added
* Special notations:
* - _[variable]
* - _[variable:string] or _[variable:s]
* - _[variable:enum] or _[variable:e]
* - _[variable:dynenum] or _[variable:y]
* - _[variable:alist] or _[variable:a]
* - _[variable:dialog] or _[variable:d]
* - _[variable.( expr ):string] (etc.)
*
* - _[variable] <- value
* - _[variable:string] <- value (etc.)
*)
(* Note:
* MLast.CrMth has four arguments until O'Caml 3.04. Later versions take
* five arguments, as in the following code.
*)
let find_prepare_page_methods nodes =
List.map
(fun node ->
match node with
MLast.CrMth(_,name,_,_,_) ->
name
| _ ->
assert false)
(List.filter
(fun node ->
match node with
MLast.CrMth(_,name,_,_,_) ->
String.length name >= 9 & String.sub name 0 8 = "prepare_"
| _ ->
false
)
nodes
)
;;
let find_handle_methods nodes =
List.map
(fun node ->
match node with
MLast.CrMth(_,name,_,_,_) ->
name
| _ ->
assert false)
(List.filter
(fun node ->
match node with
MLast.CrMth(_,name,_,_,_) ->
(String.length name >= 8 & String.sub name 0 7 = "handle_")
or (name = "handle")
| _ ->
false
)
nodes
)
;;
let make_prepare_page_dispatcher loc names =
(* Creates a method as follows:
* method prepare_page =
* match self # page_name with
* name1 -> self # prepare_<name1>
* | name2 -> self # prepare_<name2>
* ...
* | _ -> ()
*)
let cases =
List.map
(fun name ->
let pagename = String.sub name 8 (String.length name - 8) in
(* <:match_case< $lid:name$ -> self # $lid:methodname$>> *)
( <:patt< $str:pagename$>>, (* pattern *)
None, (* "when" clause *)
<:expr< self # $name$ ()>> (* -> expression *)
)
)
names
@ [ <:patt< _ >>, None, <:expr< () >> ]
in
let names' = List.map (fun s ->
let s' =
String.sub s 8 (String.length s - 8) in
<:expr< $str:s'$ >>
) names in
let namelist = Pa_o.mklistexp loc None names' in
let body = <:expr<
let pages = self # page_names in
let _ = List.iter (fun n ->
if not (List.mem n pages)
then
raise
(Wd_types.Runtime_error
("No page defined for method prepare_" ^ n))
else
()
)
$namelist$ in
match self # page_name with [ $list:cases$ ]>> in
<:class_str_item< method prepare_page() = $body$>>
;;
let make_handle_dispatcher loc names =
(* Creates a method as follows:
* method handle =
* match self # page_name with
* name1 -> self # handle_<name1>
* | name2 -> self # handle_<name2>
* ...
* | _ -> ()
*)
let cases =
List.map
(fun name ->
let pagename = String.sub name 7 (String.length name - 7) in
(* <:match_case< $lid:name$ -> self # $lid:methodname$>> *)
( <:patt< $str:pagename$>>, (* pattern *)
None, (* "when" clause *)
<:expr< self # $name$ ()>> (* -> expression *)
)
)
names
@ [ <:patt< _ >>, None, <:expr< () >> ]
in
let names' = List.map (fun s ->
let s' =
String.sub s 7 (String.length s - 7) in
<:expr< $str:s'$ >>
) names in
let namelist = Pa_o.mklistexp loc None names' in
let body = <:expr<
let pages = self # page_names in
let _ = List.iter (fun n ->
if not (List.mem n pages)
then
raise
(Wd_types.Runtime_error
("No page defined for method handle_" ^ n))
else
()
)
$namelist$ in
match self # page_name with [ $list:cases$ ]>> in
<:class_str_item< method handle () = $body$>>
;;
let modify_class_structure loc cf =
let names = find_prepare_page_methods cf in
(* If there is already a method "prepare_page", output a warning and
* leave the method as it is.
*)
let cf' =
if List.mem "prepare_page" names then begin
(* Output warning *)
!warning loc "This object already defines the method 'prepare_page'; it is not generated";
cf
end
else begin
(* Add the generated method: *)
!warning loc ("FYI: Generating method 'prepare_page' that dispatches among: " ^ (String.concat ", " names));
let m = make_prepare_page_dispatcher loc names in
m :: cf
end
in
(* Same for "handle" method: *)
let names = find_handle_methods cf' in
if List.mem "handle" names then begin
(* Output warning *)
!warning loc "This object already defines the method 'handle'; it is not generated";
cf'
end
else begin
(* Add the generated method: *)
!warning loc ("FYI: Generating method 'handle' that dispatches among: " ^
(String.concat ", " names));
let m = make_handle_dispatcher loc names in
m :: cf'
end
;;
EXTEND
GLOBAL: class_expr expr;
(* The new "interactive object": *)
class_expr: AFTER "simple"
[ [ "interactive";
"object";
cspo = OPT class_self_patt; cf = class_structure; "end" ->
let cf' = modify_class_structure loc cf in
<:class_expr< object $cspo$ $list:cf'$ end >>
]
];
(* class_self_patt and class_structure are simply copied from the
* distributed pa_a.ml file of camlp4. We must copy these rules because
* they are only locally defined.
*)
class_self_patt:
[ [ "("; p = patt; ")" -> p
| "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> ]
];
class_structure:
[ [ cf = LIST0 class_str_item -> cf ] ];
(* The :"var"...: expressions: *)
expr: BEFORE "simple"
[ [
"_";"["; name = LIDENT; "]"; "<-" ->
<:expr< self # set_variable $str:name$ >>
| "_";"["; name = LIDENT; ":"; selector = LIDENT; "]"; "<-" ->
begin match selector with
("s"|"string") ->
<:expr<
(fun x ->
self # set_variable
$str:name$
(Wd_types.String_value x))
>>
| ("e"|"enum") ->
<:expr<
(fun x ->
self # set_variable
$str:name$
(Wd_types.Enum_value x))
>>
| ("y"|"dynenum"|"dyn_enum") ->
<:expr<
(fun x ->
self # set_variable
$str:name$
(Wd_types.Dyn_enum_value x))
>>
| ("d"|"dialog") ->
<:expr<
(fun x ->
self # set_variable
$str:name$
(Wd_types.Dialog_value x))
>>
| ("a"|"alist") ->
<:expr<
(fun x ->
self # set_variable
$str:name$
(Wd_types.Alist_value x))
>>
| _ ->
Stdpp.raise_with_loc loc (Failure ("Unknown selector " ^ selector))
end
| "_";"["; name = LIDENT; "]" ->
<:expr< self # variable $str:name$ >>
| "_";"["; name = LIDENT; ":"; selector = LIDENT; "]" ->
begin match selector with
("s"|"string") ->
<:expr< self # string_variable $str:name$ >>
| ("e"|"enum") ->
<:expr< self # enum_variable $str:name$ >>
| ("y"|"dynenum"|"dyn_enum") ->
<:expr< self # dyn_enum_variable $str:name$ >>
| ("d"|"dialog") ->
<:expr< self # dialog_variable $str:name$ >>
| ("a"|"alist") ->
<:expr< self # alist_variable $str:name$ >>
| _ ->
Stdpp.raise_with_loc loc (Failure ("Unknown selector " ^ selector))
end
| "_";"["; name = LIDENT; "."; "("; e = expr; ")";
":"; selector = LIDENT; "]" ->
begin match selector with
("s"|"string") ->
<:expr< self # lookup_string_variable $str:name$ $e$ >>
| ("e"|"enum") ->
<:expr< self # lookup_enum_variable $str:name$ $e$ >>
| ("y"|"dynenum"|"dyn_enum") ->
<:expr< self # lookup_dyn_enum_variable $str:name$ $e$ >>
| ("d"|"dialog") ->
<:expr< self # lookup_dialog_variable $str:name$ $e$ >>
| ("a"|"alist") ->
Stdpp.raise_with_loc loc (Failure "Selector 'alist' not possible after lookup")
| _ ->
Stdpp.raise_with_loc loc (Failure ("Unknown selector " ^ selector))
end
]
];
END;;
(* ======================================================================
* History:
*
* $Log: wd_extension.ml,v $
* Revision 3.4 2002-09-25 00:19:20 stolpmann
* Works now (ONLY) for O'Caml 3.06
*
* Revision 3.3 2002/02/14 16:16:01 stolpmann
* Added copyright notice.
*
* Revision 3.2 2002/02/13 00:17:49 stolpmann
* Updated
*
* Revision 3.1 2002/02/12 20:35:03 stolpmann
* Initial revision.
*
* Revision 1.1 2002/01/14 15:04:00 gerd
* Syntax change: using _(var) instead of `var`
*
* Revision 1.1 2000/04/13 17:43:08 gerd
* Initial revision.
*
*
*)
