tools/zoggy/pa_zog.ml

   1 (**************************************************************************)
   2 (*                   Cameleon                                             *)
   3 (*                                                                        *)
   4 (*      Copyright (C) 2002 Institut National de Recherche en Informatique et   *)
   5 (*      en Automatique. All rights reserved.                              *)
   6 (*                                                                        *)
   7 (*      This program is free software; you can redistribute it and/or modify  *)
   8 (*      it under the terms of the GNU General Public License as published by  *)
   9 (*      the Free Software Foundation; either version 2 of the License, or  *)
  10 (*      any later version.                                                *)
  11 (*                                                                        *)
  12 (*      This program is distributed in the hope that it will be useful,   *)
  13 (*      but WITHOUT ANY WARRANTY; without even the implied warranty of    *)
  14 (*      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the     *)
  15 (*      GNU General Public License for more details.                      *)
  16 (*                                                                        *)
  17 (*      You should have received a copy of the GNU General Public License  *)
  18 (*      along with this program; if not, write to the Free Software       *)
  19 (*      Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA          *)
  20 (*      02111-1307  USA                                                   *)
  21 (*                                                                        *)
  22 (*      Contact: Maxence.Guesdon@inria.fr                                *)
  23 (**************************************************************************)
  24
  25 (* $Id$ *)
  26
  27 (*
  28 #load "pa_extend.cmo";;
  29 *)
  30 #load "q_MLast.cmo";;
  31
  32 (** Code generation from Zoggy input *)
  33
  34 open Zog_types
  35
  36 exception Field_error of string
  37
  38 (* BEGIN CDK *)
  39
  40 let anonymous_name_counter = ref 0
  41
  42 let gen_anonynous_name ele =
  43   if ele.name = "_" && ele.children <> [] then begin
  44       incr anonymous_name_counter;
  45       ele.name <- Printf.sprintf "_anonymous_container_%d"
  46         !anonymous_name_counter;
  47     end
  48
  49 (* END CDK *)
  50
  51 module Zoggy(Syntax : Camlp4.Sig.Camlp4Syntax) =
  52 struct
  53   open Camlp4.PreCast
  54
  55   include Syntax
  56 (*   open Ast *)
  57
  58 let parse_string loc =
  59   function
  60     "false" ->
  61 (*
  62       let loc =
  63         (
  64          { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
  65          { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
  66         )
  67       in
  68 *)
  69       <:expr@loc< False >>
  70   | "true" ->
  71 (*
  72       let loc =
  73         (
  74          { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
  75          { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
  76         )
  77       in
  78 *)
  79       <:expr@loc< True >>
  80
  81   | str ->
  82       try
  83 (*         let strm = Stream.of_string str in *)
  84         Gram.parse_string expr loc str
  85 (*
  86         Pcaml.expr_reloc
  87           (fun _ -> Lexing.dummy_pos, Lexing.dummy_pos)
  88           Lexing.dummy_pos
  89           r
  90 *)
  91       with
  92         e ->
  93           Printf.eprintf "Error in \"%s\"\n" str; flush stderr;
  94           let (e, loc) =
  95             match e with
  96             | Loc.Exc_located (loc, e) -> e, loc
  97             | e -> e, loc
  98           in
  99           Loc.raise loc e
 100
 101 (** parsing a prop value *)
 102 let parse_prop_value prop =
 103 (*   let loc = fst prop.prop_value_loc + 1, snd prop.prop_value_loc - 1 in *)
 104   parse_string prop.prop_value_loc prop.prop_value
 105
 106 let ast_of_class_info loc cl =
 107   let (_, _, _, fonc) = Zog_types.get_class_info cl in parse_string loc fonc
 108
 109 (** Return the value of a property kind in a list of properties. *)
 110 let ast_of_prop_value loc props kind =
 111   try
 112     let p = List.find (fun p -> p.prop_kind = kind) props in
 113     parse_prop_value p
 114   with
 115     Not_found ->
 116 (*
 117         let loc =
 118           (
 119            { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
 120            { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
 121           )
 122         in
 123 *)
 124         <:expr@loc< "" >>
 125
 126 let get_prop_label ele prop =
 127   match prop.prop_kind with
 128   | Function -> ""
 129   | Expand -> "expand"
 130   | Fill -> "fill"
 131   | Padding -> "padding"
 132   | Width -> "width"
 133   | Height -> "height"
 134   | Border_width -> "border_width"
 135   | Title -> "title"
 136   | Allow_shrink -> "allow_shrink"
 137   | Allow_grow -> "allow_grow"
 138   | Auto_shrink -> "auto_shrink"
 139   | X_pos -> "x"
 140   | Y_pos -> "y"
 141   | PLabel -> "label"
 142   | Group -> "group"
 143   | Orientation -> "orientation"
 144   | Toolbar_style -> "style"
 145   | Toolbar_space_size -> "space_size"
 146   | Toolbar_space_style -> "space_style"
 147   | Tooltips -> "tooltips"
 148   | Button_relief_style -> "button_relief"
 149   | Spacing -> "spacing"
 150   | Homogeneous -> "homogeneous"
 151   | Button_box_style -> "layout"
 152   | Child_width -> "child_width"
 153   | Child_height -> "child_height"
 154   | Child_ipadx -> "child_ipadx"
 155   | Child_ipady -> "child_ipady"
 156   | Label_xalign -> "label_xalign"
 157   | Label_yalign -> "label_yalign"
 158   | Shadow_type ->
 159       begin match ele.classe with
 160         Arrow -> "shadow"
 161       | _ -> "shadow_type"
 162       end
 163   | Obey_child -> "obey_child"
 164   | Ratio -> "ratio"
 165   | Hscrollbar_policy -> "hpolicy"
 166   | Vscrollbar_policy -> "vpolicy"
 167   | Handle_position -> "handle_position"
 168   | Snap_edge -> "snap_edge"
 169   | Column_titles -> "titles"
 170   | Show_titles -> "titles_show"
 171   | X_align -> "xalign"
 172   | Y_align -> "yalign"
 173   | X_pad -> "xpad"
 174   | Y_pad -> "ypad"
 175   | PText -> "text"
 176   | Line_wrap -> "line_wrap"
 177   | Tab_pos -> "tab_pos"
 178   | Show_tabs -> "show_tabs"
 179   | Homogeneous_tabs -> "homogeneous_tabs"
 180   | Show_border -> "show_border"
 181   | Scrollable -> "scrollable"
 182   | Tab_border -> "tab_border"
 183   | Popup -> "popup"
 184   | SBUpdate_policy -> "update_policy"
 185   | Visibility -> "visibility"
 186   | Editable -> "editable"
 187   | Use_arrows -> "use_arrows"
 188   | Case_sensitive -> "case_sensitive"
 189   | Word_wrap -> "word_wrap"
 190   | Column_number -> "columns"
 191   | Draw_indicator -> "draw_indicator"
 192   | Active -> "active"
 193   | Placement -> "placement"
 194   | Selection_mode -> "selection_mode"
 195   | Justification -> "justify"
 196   | Max_length -> "max_length"
 197   | View_mode -> "view_mode"
 198   | View_lines -> "view_lines"
 199   | Handle_size -> "handle_size"
 200   | Modal -> "modal"
 201   | Tab_label -> ""
 202   | Accel_group_name | Accel_modifier | Accel_flags | Accel_keysym |
 203     Show_toggle | Show_indicator | Right_justify ->
 204       ""
 205   | Arrow_type -> "kind"
 206   | Calendar_options -> "options"
 207   | Popdown_strings -> "popdown_strings"
 208   | Value_in_list -> "value_in_list"
 209   | Ok_if_empty -> "ok_if_empty"
 210   | Update_policy -> "update_policy"
 211
 212   | PPixmap_file | PPixmap_data | PPixmap_code -> ""
 213
 214 (** Remove blanks (space, tabs, \r and \n) from a string. *)
 215 let remove_blanks s =
 216   let buf = Buffer.create 16 in
 217   let f c =
 218     match c with
 219       ' ' | '\n' | '\t' | '\r' -> ()
 220     | _ ->
 221         Buffer.add_char buf c
 222   in
 223   String.iter f s;
 224   Buffer.contents buf
 225
 226 (** Indicate whether a property param must be printed.*)
 227 let must_gen prop =
 228   try
 229     let (_, _, values_kind, _) = Zog_types.get_prop_info prop.prop_kind in
 230     match values_kind with
 231       Bool -> true
 232     | PosInt ->
 233         begin try int_of_string prop.prop_value >= 0 with
 234           _ -> (remove_blanks prop.prop_value) <> ""
 235         end
 236     | Float -> (remove_blanks prop.prop_value) <> ""
 237     | Code | Code_list -> (remove_blanks prop.prop_value) <> ""
 238     | Enum [] -> false
 239     | Enum ((s, _) :: _) -> true
 240     | Enum_list [] -> false
 241     | Enum_list ((s, _) :: _) -> true
 242     | Keysym ->
 243         let v_no_blank = remove_blanks prop.prop_value in v_no_blank <> ""
 244   with
 245     Failure s -> prerr_endline s; false
 246
 247 let field_error_string f =
 248   match List.find (fun (x, _, _, _) -> x = f) Zog_types.properties with
 249       (_, n, _, _) -> n
 250
 251 let ast_of_creation_options_code (loc:Loc.t) ele f =
 252 (*
 253   let loc =
 254     (
 255      { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
 256      { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
 257     )
 258   in
 259 *)
 260
 261   let g f prop =
 262     match prop.prop_kind with
 263       Function | Tab_label | Expand | Fill | Padding -> f
 264     | Accel_modifier | Accel_group_name | Accel_flags | Accel_keysym | Show_toggle |
 265       Show_indicator | Right_justify ->
 266         f
 267     | PPixmap_file ->
 268         if must_gen prop then
 269           let v = parse_prop_value prop in
 270           <:expr< $f$ (GDraw.pixmap_from_xpm ~file : $v$ ()) >>
 271         else
 272           raise (Field_error (field_error_string PPixmap_file))
 273     | PPixmap_data ->
 274         if must_gen prop then
 275           let v = parse_prop_value prop in
 276           <:expr< $f$ (GDraw.pixmap_from_xpm_d ~data : $v$ ()) >>
 277         else
 278           raise (Field_error (field_error_string PPixmap_data))
 279     | PPixmap_code ->
 280         if must_gen prop then
 281           let v = parse_prop_value prop in
 282           <:expr< $f$ $v$ >>
 283         else
 284           raise (Field_error (field_error_string PPixmap_code))
 285     | _ ->
 286         if must_gen prop then
 287           let v = parse_prop_value prop in
 288           <:expr< $f$ ~ $get_prop_label ele prop$ : $v$ >>
 289         else f
 290   in
 291   List.fold_left g f ele.props
 292
 293 let ast_of_pack_options_code loc f ele =
 294   let g f prop =
 295     match prop.prop_kind with
 296       Expand | Fill | Padding ->
 297         if must_gen prop then
 298 (*
 299           let loc =
 300             (
 301              { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
 302              { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
 303             )
 304           in
 305 *)
 306           let v = parse_prop_value prop in
 307           <:expr< $f$ ~ $get_prop_label ele prop$ : $v$ >>
 308         else f
 309     | _ -> f
 310   in
 311   List.fold_left g f ele.props
 312
 313 let ast_of_pack_code loc parent ele f =
 314   try
 315     let pack_met = Zog_types.pack_method_of_ele parent ele in
 316     match pack_met with
 317       No_pack -> f
 318     | Insert_page ->
 319         let g =
 320 (*
 321           let loc =
 322             (
 323              { Lexing.dummy_pos with Lexing.pos_cnum = fst parent.name_loc } ,
 324              { Lexing.dummy_pos with Lexing.pos_cnum = snd parent.name_loc }
 325             )
 326           in
 327 *)
 328           <:expr< $lid:parent.name$ >>
 329         in
 330         let loc1 = loc in
 331 (*
 332         let loc =
 333           (
 334            { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
 335            { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
 336           )
 337         in
 338 *)
 339         <:expr<
 340           $f$ ~packing:
 341             (fun w ->
 342                $g$ # append_page
 343                  ~tab_label:
 344                     (GMisc.label
 345                         ~text:$ast_of_prop_value loc1 ele.props Tab_label$ ())
 346                     #coerce w)
 347         >>
 348     | _ ->
 349         let g =
 350 (*         let loc = parent.name_loc in *)
 351 (* FIXME
 352           let loc =
 353             (
 354              { Lexing.dummy_pos with Lexing.pos_cnum = fst parent.name_loc } ,
 355              { Lexing.dummy_pos with Lexing.pos_cnum = snd parent.name_loc }
 356             )
 357           in
 358 *)
 359           <:expr< $lid:parent.name$ >>
 360         in
 361         let loc1 = loc in
 362 (*
 363         let loc =
 364           (
 365            { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
 366            { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
 367           )
 368         in
 369 *)
 370         let p x = <:expr< $f$ ~packing: $x$ >> in
 371         match pack_met with
 372           Pack -> p (ast_of_pack_options_code loc1 <:expr< $g$ # pack >> ele)
 373         | Add -> p <:expr< $g$ # add >>
 374         | Add1 -> p <:expr< $g$ # add1 >>
 375         | Add2 -> p <:expr< $g$ # add2 >>
 376         | Add_with_viewport -> p <:expr< $g$ # add_with_viewport >>
 377         | Set_submenu -> p <:expr< $g$ # set_submenu >>
 378         | Insert_page | No_pack -> f
 379   with
 380     Failure s ->
 381 (*
 382         let loc =
 383           (
 384            { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
 385            { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
 386           )
 387         in
 388 *)
 389         prerr_endline s;
 390         <:expr< $f$ failed >>
 391
 392 let ast_of_custom_pack_code loc parent ele ce =
 393   try
 394     let pack_met = Zog_types.pack_method_of_ele parent ele in
 395     match pack_met with
 396       No_pack -> ce
 397     | Insert_page ->
 398
 399         let g =
 400 (* FIXME
 401           let loc =
 402             (
 403              { Lexing.dummy_pos with Lexing.pos_cnum = fst parent.name_loc } ,
 404              { Lexing.dummy_pos with Lexing.pos_cnum = snd parent.name_loc }
 405             )
 406           in
 407 *)
 408           <:expr< $lid:parent.name$>>
 409         in
 410         let n =
 411 (* FIXME
 412           let loc =
 413             (
 414              { Lexing.dummy_pos with Lexing.pos_cnum = fst ele.name_loc } ,
 415              { Lexing.dummy_pos with Lexing.pos_cnum = snd ele.name_loc }
 416             )
 417           in
 418 *)
 419           <:expr< $lid:ele.name$ >>
 420         in
 421         let loc1 = loc in
 422 (*
 423         let loc =
 424           (
 425            { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
 426            { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
 427           )
 428         in
 429 *)
 430
 431         <:class_expr<
 432         let _ = $g$ # append_page
 433             ~tab_label:
 434             (GMisc.label
 435                ~text:$ast_of_prop_value loc1 ele.props
 436                Tab_label$ ())
 437             #coerce $n$#coerce in
 438         $ce$
 439         >>
 440     | _ ->
 441
 442         let g =
 443 (* FIXME
 444           let loc =
 445             (
 446              { Lexing.dummy_pos with Lexing.pos_cnum = fst parent.name_loc } ,
 447              { Lexing.dummy_pos with Lexing.pos_cnum = snd parent.name_loc }
 448             )
 449           in
 450 *)
 451           <:expr< $lid:parent.name$ >>
 452         in
 453         let loc1 = loc in
 454 (*
 455         let loc =
 456           (
 457            { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
 458            { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
 459           )
 460         in
 461 *)
 462         let r =
 463           match pack_met with
 464             Pack -> ast_of_pack_options_code loc1 <:expr< $g$ # pack >> ele
 465           | Add -> <:expr< $g$ # add >>
 466           | Add1 -> <:expr< $g$ # add1 >>
 467           | Add2 -> <:expr< $g$ # add2 >>
 468           | Add_with_viewport -> <:expr< $g$ # add_with_viewport >>
 469           | Set_submenu -> <:expr< $g$ # set_submenu >>
 470           | Insert_page | No_pack -> g
 471         in
 472         let n =
 473 (* FIXME
 474           let loc =
 475             (
 476              { Lexing.dummy_pos with Lexing.pos_cnum = fst ele.name_loc } ,
 477              { Lexing.dummy_pos with Lexing.pos_cnum = snd ele.name_loc }
 478             )
 479           in
 480 *)
 481           <:expr< $lid:ele.name$ >>
 482         in
 483         <:class_expr< let _ = $r$ $n$ # coerce in $ce$ >>
 484   with
 485     Failure s ->
 486 (*
 487       let loc =
 488         (
 489          { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
 490          { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
 491           )
 492       in
 493 *)
 494       prerr_endline s;
 495       <:class_expr< let _ = failed in $ce$ >>
 496
 497 (** The accel_group variable name for the given Menubar ele. *)
 498 let accel_group_name ele =
 499   let accel_group_v = Zog_types.get_prop_value ele.props Accel_group_name in
 500   let name =
 501     match remove_blanks accel_group_v with
 502       "" -> "accel_" ^ ele.name
 503     | s -> s
 504   in
 505   name
 506
 507 (** Output the OCaml for the given menu_item (or check or radio)
 508    and its optional submenu, to perform after creation initializations
 509    like adding accelerators and fixing some properties. *)
 510 let rec ast_of_post_menu_item_creation_code loc accel_name ele ce =
 511   let keysym_v = Zog_types.get_prop_value ele.props Accel_keysym in
 512   let ce =
 513     List.fold_right (ast_of_post_menu_creation_code loc accel_name)
 514       ele.children ce
 515   in
 516   match remove_blanks keysym_v with
 517     "" -> ce
 518   | v ->
 519       let modifier =
 520         match
 521           remove_blanks (Zog_types.get_prop_value ele.props Accel_modifier)
 522         with
 523           "" ->
 524 (*
 525             let loc =
 526             (
 527              { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
 528              { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
 529             )
 530             in
 531 *)
 532             <:expr< [] >>
 533         | s -> parse_string loc s
 534       in
 535       let flags =
 536         match
 537           remove_blanks (Zog_types.get_prop_value ele.props Accel_flags)
 538         with
 539           "" ->
 540 (*
 541             let loc =
 542             (
 543              { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
 544              { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
 545             )
 546             in
 547 *)
 548             <:expr< [] >>
 549         | s -> parse_string loc s
 550       in
 551       let loc1 = loc in
 552 (*
 553       let loc =
 554         (
 555          { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
 556          { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
 557         )
 558       in
 559 *)
 560       <:class_expr<
 561         let _ =
 562           $lid:ele.name$ #add_accelerator ~group: $lid:accel_name$
 563              ~modi: $modifier$ ~flags: $flags$ $parse_string loc1 v$
 564         in
 565         $ce$ >>
 566
 567 and ast_of_post_menu_creation_code loc accel_name ele ce =
 568   match ele.classe with
 569     Menu ->
 570       let ce =
 571         List.fold_right (ast_of_post_menu_item_creation_code loc accel_name)
 572           ele.children ce
 573       in
 574 (*
 575       let loc =
 576         (
 577          { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
 578          { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
 579         )
 580       in
 581 *)
 582       <:class_expr<
 583          let _ = $lid:ele.name$ #set_accel_group $lid:accel_name$ in $ce$ >>
 584   | _ -> ce
 585
 586 (** Output the OCaml for the given element which must be a Menubar. *)
 587 let ast_of_post_menubar_creation_code ?win loc ele ce =
 588   match ele.classe with
 589     Menubar ->
 590       let acc_name = accel_group_name ele in
 591       let ce =
 592         List.fold_right (ast_of_post_menu_item_creation_code loc acc_name)
 593           ele.children ce
 594       in
 595       let ce2 =
 596         (
 597          match win with
 598            None -> ce
 599          | Some w ->
 600 (*
 601              let loc =
 602                (
 603                 { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
 604                 { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
 605                )
 606              in
 607 *)
 608              <:class_expr<
 609              let _ = $lid:w$#add_accel_group $lid:acc_name$ in $ce$
 610              >>
 611         )
 612       in
 613 (*
 614       let loc =
 615         (
 616          { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
 617          { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
 618         )
 619       in
 620 *)
 621       <:class_expr<
 622       let $lid:acc_name$ = GtkData.AccelGroup.create () in
 623       $ce2$
 624       >>
 625
 626   | _ -> ce
 627
 628 let rec ast_of_ele_creations ?win loc parent_opt previous_opt ele ce =
 629   let ce = ast_of_post_menubar_creation_code ?win loc ele ce in
 630   let ce =
 631     let rec iter prev ce =
 632       function
 633         [] -> ce
 634       | e :: q ->
 635           let ce = iter (Some e) ce q in
 636           ast_of_ele_creations ?win loc (Some ele) prev e ce
 637     in
 638     iter None ce ele.children
 639   in
 640   let e =
 641     if ele.classe = Custom_box then ast_of_prop_value loc ele.props Function
 642     else
 643       let f = ast_of_class_info ele.name_loc ele.classe in
 644       let f = ast_of_creation_options_code loc ele f in
 645       let f =
 646         match ele.classe, previous_opt with
 647           Radio_menu_item, Some e when e.classe = Radio_menu_item ->
 648 (*
 649             let loc =
 650               (
 651                { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
 652                { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
 653               )
 654             in
 655 *)
 656             <:expr< $f$ ~group: $lid:e.name$ #group >>
 657         | _ -> f
 658       in
 659       match parent_opt with
 660         None -> f
 661       | Some parent -> ast_of_pack_code loc parent ele f
 662   in
 663   let ce =
 664     if ele.classe = Custom_box then
 665       match parent_opt with
 666         None -> ce
 667       | Some parent -> ast_of_custom_pack_code loc parent ele ce
 668     else ce
 669     in
 670 (* BEGIN CDK *)
 671   gen_anonynous_name ele;
 672   if ele.name = "_" then
 673 (*
 674         let loc =
 675           (
 676            { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
 677            { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
 678           )
 679         in
 680 *)
 681         <:class_expr< let _ = $e$ () in $ce$  >>
 682     else
 683     (* END CDK *)
 684   let n =
 685 (* FIXME
 686     let loc =
 687       (
 688        { Lexing.dummy_pos with Lexing.pos_cnum = fst ele.name_loc } ,
 689        { Lexing.dummy_pos with Lexing.pos_cnum = snd ele.name_loc }
 690           )
 691     in
 692 *)
 693     <:patt< $lid:ele.name$ >>
 694   in
 695 (*
 696   let loc =
 697     (
 698      { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
 699      { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
 700     )
 701   in
 702 *)
 703   <:class_expr< let $n$ = $e$ () in $ce$ >>
 704
 705   let rec ast_of_ele_methods loc ele =
 706     let cil =
 707       if ele.classe = Menubar then
 708         let accel_name = accel_group_name ele in
 709 (*
 710         let loc =
 711           (
 712            { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
 713            { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
 714           )
 715         in
 716 *)
 717         [ <:class_str_item< method $accel_name$ = $lid:accel_name$ >> ]
 718       else []
 719     in
 720 (* BEGIN CDK *)
 721     gen_anonynous_name ele;
 722     let cil = if ele.name.[0] <> '_' then
 723       let n =
 724 (* FIXME
 725         let loc =
 726           (
 727            { Lexing.dummy_pos with Lexing.pos_cnum = fst ele.name_loc } ,
 728            { Lexing.dummy_pos with Lexing.pos_cnum = snd ele.name_loc }
 729           )
 730         in
 731 *)
 732         <:expr< $lid:ele.name$ >>
 733       in
 734 (*
 735       let loc =
 736         (
 737          { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
 738          { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
 739         )
 740       in
 741 *)
 742       <:class_str_item< method $ele.name$ = $n$ >> :: cil else cil in
 743 (* END CDK *)
 744     List.fold_left (fun cil ele -> cil @ ast_of_ele_methods loc ele) cil
 745       ele.children
 746
 747 let rec ast_of_ele_vals loc ele =
 748   let cil =
 749     if ele.classe = Menubar then
 750       let accel_name = accel_group_name ele in
 751 (*
 752       let loc =
 753         (
 754          { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
 755          { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
 756         )
 757       in
 758 *)
 759       [ <:class_str_item< value $accel_name$ = $lid:accel_name$ >> ]
 760     else []
 761   in
 762 (* BEGIN CDK *)
 763   gen_anonynous_name ele;
 764   let n =
 765 (* FIXME
 766     let loc =
 767       (
 768        { Lexing.dummy_pos with Lexing.pos_cnum = fst ele.name_loc } ,
 769        { Lexing.dummy_pos with Lexing.pos_cnum = snd ele.name_loc }
 770       )
 771     in
 772 *)
 773     <:expr< $lid:ele.name$ >>
 774   in
 775   let cil = if ele.name.[0] <> '_' then
 776 (*
 777     let loc =
 778       (
 779        { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
 780        { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
 781       )
 782     in
 783 *)
 784     <:class_str_item< value $ele.name$ = $n$ >> :: cil
 785    else cil
 786   in
 787 (* END CDK *)
 788   List.fold_left (fun cil ele -> cil @ ast_of_ele_vals loc ele) cil
 789     ele.children
 790
 791 let ast_of_entity loc entity =
 792   let ce =
 793     let cil =
 794       match entity.en_ele with
 795         None -> []
 796       | Some e ->
 797           let cil = ast_of_ele_vals loc e @ ast_of_ele_methods loc e in
 798           match e.classe with
 799             Window -> cil
 800           | _ ->
 801               let n =
 802 (* FIXME
 803                 let loc =
 804                   (
 805                    { Lexing.dummy_pos with Lexing.pos_cnum = fst e.name_loc } ,
 806                    { Lexing.dummy_pos with Lexing.pos_cnum = snd e.name_loc }
 807                   )
 808                 in
 809 *)
 810     <:expr< $lid:e.name$ >>
 811               in
 812 (*
 813               let loc =
 814                 (
 815                  { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
 816                  { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
 817                 )
 818               in
 819 *)
 820               let ci = <:class_str_item< method coerce = $n$ # coerce >> in
 821               cil @ [ci]
 822     in
 823 (*
 824     let loc =
 825       (
 826        { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
 827        { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
 828       )
 829     in
 830 *)
 831     <:class_expr@loc< object (*$None$*) $list:cil$ end >>
 832   in
 833   let ce =
 834     match entity.en_ele with
 835       None -> ce
 836     | Some ele ->
 837         let win_opt =
 838           match ele.classe with
 839             Window -> Some ele.name
 840           | _ -> None
 841         in
 842         ast_of_ele_creations ?win: win_opt loc None None ele ce
 843   in
 844 (*
 845   let loc =
 846     (
 847      { Lexing.dummy_pos with Lexing.pos_cnum = fst loc } ,
 848      { Lexing.dummy_pos with Lexing.pos_cnum = snd loc }
 849           )
 850   in
 851 *)
 852   let ce =
 853     List.fold_right (fun p ce -> <:class_expr< fun $lid:p$ -> $ce$ >>)
 854       entity.en_params <:class_expr< fun () -> $ce$ >>
 855   in
 856   <:str_item@loc< class $lid:entity.en_name$ = $ce$ >>
 857
 858 (* Parser for Zoggy input (XML) *)
 859
 860 (* let gram = Grammar.create (Plexer.make ()) *)
 861 (* let project = Gram.Entry.mk gram "project" *)
 862 ;;
 863 Gram.Entry.clear implem;;
 864
 865 let field_error s =
 866   Printf.eprintf "Error: field %s is empty\n" s
 867
 868 let eoi : 'eoi Gram.Entry.t = Gram.Entry.mk "eoi"
 869 let () =
 870   Gram.extend (eoi : 'eoi Gram.Entry.t)
 871    ((fun () ->
 872        (None,
 873         [ (None, None,
 874            [ ([ Gram.Stoken
 875                   (((function | EOI -> true | _ -> false),
 876                     "EOI")) ],
 877               (Gram.Action.mk
 878                  (fun (__camlp4_0 : Gram.Token.t) (loc : Gram.Loc.t)
 879                     ->
 880                     match __camlp4_0 with
 881                     | EOI -> (() : 'eoi)
 882                     | _ -> assert false))) ]) ]))
 883       ())
 884
 885   EXTEND Gram
 886 (*     GLOBAL: project; *)
 887     GLOBAL: implem;
 888     implem:
 889       [ [ el = LIST0 entity ; eoi -> el, None ] ]
 890     ;
 891 (*     eoi: [[ EOI -> () ]]; *)
 892     entity:
 893       [ [ "<"; LIDENT "entity"; LIDENT "name"; "="; name = LIDENT;
 894           pl = LIST0 [ x = LIDENT -> x ]; ">"; w = OPT widget; "</"; LIDENT "entity";
 895           ">" ->
 896             try
 897               let entity = {en_name = name; en_params = pl; en_ele = w} in
 898               (
 899 (*             let loc = ((fst loc).Lexing.pos_cnum, (snd loc).Lexing.pos_cnum) in *)
 900                ast_of_entity loc entity
 901               )
 902             with Field_error m ->
 903               field_error m;
 904               exit 1
 905         ] ]
 906     ;
 907     widget:
 908       [ [ "<"; tag = LIDENT; LIDENT "name"; "="; (name, nloc) = ident;
 909           proplist = LIST0 property; ">"; children = LIST0 widget;
 910           (tag_end, loc_tend) = tag_end ->
 911             if tag <> tag_end then
 912               Loc.raise loc_tend
 913                 (Stream.Error ("</" ^ tag ^ "> expected"));
 914             let proplist =
 915               List.filter (fun (x, v, vloc) -> x <> "expanded" && x <> "in_interface") proplist
 916             in
 917             let proplist =
 918               List.map
 919                 (fun (x, v, vloc) ->
 920                    {prop_kind = Zog_misc.property_kind_of_property_name x;
 921                     prop_value = Zog_misc.decode v;
 922                      prop_value_loc = vloc})
 923 (*          ((fst vloc).Lexing.pos_cnum, (snd vloc).Lexing.pos_cnum)}) *)
 924                 proplist
 925             in
 926 (*          let nloc = ((fst loc).Lexing.pos_cnum, (snd loc).Lexing.pos_cnum) in *)
 927             { name = name; name_loc = loc;
 928               classe = Zog_misc.class_of_class_name tag;
 929               props = proplist;
 930               children = children;
 931               expanded = false ;
 932             } ] ]
 933     ;
 934     tag_end:
 935       [ [ "</"; tag = LIDENT; ">" -> tag, loc ] ]
 936     ;
 937     property:
 938       [ [ x = LIDENT; "="; (v, vloc) = string -> x, v, vloc
 939         | "function"; "="; (v, vloc) = string -> "function", v, vloc ]
 940       ]
 941     ;
 942     string:
 943       [ [ v = STRING -> v,  loc ] ]
 944     ;
 945     ident:
 946       [
 947         [ v = LIDENT -> v, loc
 948         | "_" -> "_", loc ]
 949       ]
 950     ;
 951   END
 952
 953 end
 954
 955 module Id = struct
 956 let version = "0"
 957 let name = "Zoggy"
 958 end
 959
 960 module M = Camlp4.Register.OCamlSyntaxExtension(Id)(Zoggy)
 961
 962 (* let _ = Pcaml.parse_implem := Grammar.Entry.parse project *)