On 7/5/06, Matt Gushee <matt@gushee.net> wrote:
> Jonathan Roewen wrote:
>
>  > What is the syntax for immediate objects in ocaml when using revised
> syntax?
>
> Not sure offhand, but ...
>
>  > I'd like to try make a camlp4 syntax extension that uses immediate
>  > objects,
>
> I've done that. I'll show you the key section of the code below, and I
> can send you the complete file if you like. It may not be 100% correct,
> but I've been using it in an application and so far it works. I don't
> know if I can *explain* it, though ... I wrote it several months ago,
> and I'm coming to think that CamlP4, like Perl, is a write-only language ;-)
>
> [BTW, *_si in function names means "structure item", and *_csi means
> "class structure item"]
>

Let me use this piece of code to show Camlp4 changes:

>
> let object_body loc decls =

let object_body _loc decls =

>    let sub_objects =
>      let sos =
>        List.fold_right
>          ( fun idat lst ->
>            match idat.sub_obj with
>            | None -> lst
>            | Some so -> so::lst )
>          decls [] in
>      <:class_str_item< declare $list:sos$ end >>

let sub_objects =
  List.fold_right
     (fun idat lst ->
         match idat.sub_obj with
         | None -> lst
         | Some so -> <:class_str_item< $so$; $lst$ >>)
      decls <:class_str_item<>>

>    and accessors =
>      let accs =
>        List.fold_right
>          ( fun idat lst ->
>            match idat.setter with
>            | None -> idat.getter :: lst
>            | Some se -> idat.getter :: se :: lst )
>          decls [] in
>      <:class_str_item< declare $list:accs$ end >> in

and accessors =
  List.fold_right
     (fun idat lst ->
         match idat.setter with
         | None -> <:class_str_item< $idat.getter$; $lst$ >>
         | Some so -> <:class_str_item< $idat.getter$; $se$; $lst$ >>)
      decls <:class_str_item<>> in

 (sub_objects, accessors)

>    (sub_objects, accessors)
>
> let subconf_csi loc key decls =
>    let sub_objects, accessors = object_body loc decls
>    and pself = <:patt< self >>
>    and inheritance =
>      <:class_str_item<
>        inherit sub_config data defaults path as super
>      >> in
>    let obj_expr =
>      MLast.ExObj
>        (loc, Some pself, [inheritance; sub_objects; accessors]) in
>    let keylist_expr = <:expr< [$str:key$] >> in
>    let path_bind_expr =
>      <:expr<
>        let path = path @ $keylist_expr$ in $obj_expr$
>      >>
>    and oname = key ^ "_" in
>    Some <:class_str_item< value $lid:oname$ = $path_bind_expr$ >>

let subconf_csi _loc key decls =
   let sub_objects, accessors = object_body loc decls in
      <:class_str_item<
            value $lid:oname$ =
                let path = path @ [$str:key$] in
                object (self)
                    inherit sub_config data defaults path as super;
                    $sub_objects$;
                    $accessors$;
                end >>

>
> let rootconf_si loc cname decls =
>    let sub_objects, accessors = object_body loc decls
>    and pself = <:patt< self >>
>    and inheritance =
>      <:class_str_item<
>        inherit root_config srcs dest data defaults as super
>      >> in
>    let oe =
>      MLast.ExObj
>        (loc, Some pself, [inheritance; sub_objects; accessors]) in
>    <:str_item<
>        value $lid:cname$ srcs dest =
>          let data = Dict.create ()
>          and path = [] in $oe$
>    >>

let rootconf_si _loc cname decls =
    let sub_objects, accessors = object_body loc decls in
    <:str_item<
        value $lid:cname$ srcs dest =
          let data = Dict.create ()
          and path = [] in
          object (self)
             inherit root_config srcs dest data defaults as super;
             $sub_objects$;
             $accessors$;
          end
    >>


>
> let main_si loc cname decls =
>    write_example decls;
>    let os = <:str_item< open Rascl >>
>    and oc = <:str_item< open ConfigObject >>
>    and od = <:str_item< open Dict >>
>    and defcreate = <:str_item< value defaults = create () >>
>    and defsetup0 = top_doin_expr loc [] decls in
>    let defsetup = <:str_item< $exp:defsetup0$ >>
>    and cl = rootconf_si loc cname decls in
>    let all = [os; oc; od; defcreate; defsetup; cl] in
>    <:str_item< declare $list:all$ end >>
>

let main_si _loc cname decls =
<:str_item<
    open Rascl;
    open ConfigObject;
    open Dict;
    value defaults = create ();
    $exp:top_doin_expr _loc [] decls$;
    $rootconf_si loc cname decls$ >>

-- 
Nicolas Pouillard