Re: [Caml-list] revised syntax and immediate objects

["Nicolas Pouillard" <nicolas.pouillard@inria.fr>]

[-- Attachment #1: Type: text/plain, Size: 4539 bytes --]

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

[-- Attachment #2: without-quotations.ml --]
[-- Type: text/plain, Size: 4337 bytes --]

let object_body _loc decls =
  let sub_objects =
    List.fold_right
      (fun idat lst ->
         match idat.sub_obj with
         | None -> lst
         | Some so -> Ast.CrSem (_loc, so, lst))
      decls (Ast.CrNil _loc)
  and accessors =
    List.fold_right
      (fun idat lst ->
         match idat.setter with
         | None -> Ast.CrSem (_loc, idat.getter, lst)
         | Some so ->
             Ast.CrSem (_loc, idat.getter, Ast.CrSem (_loc, se, lst)))
      decls (Ast.CrNil _loc)
  in (sub_objects, accessors)
let subconf_csi _loc key decls =
  let (sub_objects, accessors) = object_body loc decls
  in
    Ast.CrVal (_loc, oname, Ast.BFalse,
      Ast.ExLet (_loc, Ast.BFalse,
        Ast.BiEq (_loc, Ast.PaId (_loc, Ast.IdLid (_loc, "path")),
          Ast.ExApp (_loc,
            Ast.ExApp (_loc, Ast.ExId (_loc, Ast.IdLid (_loc, "@")),
              Ast.ExId (_loc, Ast.IdLid (_loc, "path"))),
            Ast.ExApp (_loc,
              Ast.ExApp (_loc, Ast.ExId (_loc, Ast.IdUid (_loc, "::")),
                Ast.ExStr (_loc, key)),
              Ast.ExId (_loc, Ast.IdUid (_loc, "[]"))))),
        Ast.ExObj (_loc, Ast.PaId (_loc, Ast.IdLid (_loc, "self")),
          Ast.CrSem (_loc,
            Ast.CrInh (_loc,
              Ast.CeApp (_loc,
                Ast.CeApp (_loc,
                  Ast.CeApp (_loc,
                    Ast.CeCon (_loc, Ast.BFalse,
                      Ast.IdLid (_loc, "sub_config"), Ast.TyNil _loc),
                    Ast.ExId (_loc, Ast.IdLid (_loc, "data"))),
                  Ast.ExId (_loc, Ast.IdLid (_loc, "defaults"))),
                Ast.ExId (_loc, Ast.IdLid (_loc, "path"))),
              "super"),
            Ast.CrSem (_loc, sub_objects, accessors)))))
let rootconf_si _loc cname decls =
  let (sub_objects, accessors) = object_body loc decls
  in
    Ast.StVal (_loc, Ast.BFalse,
      Ast.BiEq (_loc, Ast.PaId (_loc, Ast.IdLid (_loc, cname)),
        Ast.ExFun (_loc,
          Ast.McArr (_loc, Ast.PaId (_loc, Ast.IdLid (_loc, "srcs")),
            Ast.ExNil _loc,
            Ast.ExFun (_loc,
              Ast.McArr (_loc, Ast.PaId (_loc, Ast.IdLid (_loc, "dest")),
                Ast.ExNil _loc,
                Ast.ExLet (_loc, Ast.BFalse,
                  Ast.BiAnd (_loc,
                    Ast.BiEq (_loc,
                      Ast.PaId (_loc, Ast.IdLid (_loc, "data")),
                      Ast.ExApp (_loc,
                        Ast.ExId (_loc,
                          Ast.IdAcc (_loc, Ast.IdUid (_loc, "Dict"),
                            Ast.IdLid (_loc, "create"))),
                        Ast.ExId (_loc, Ast.IdUid (_loc, "()")))),
                    Ast.BiEq (_loc,
                      Ast.PaId (_loc, Ast.IdLid (_loc, "path")),
                      Ast.ExId (_loc, Ast.IdUid (_loc, "[]")))),
                  Ast.ExObj (_loc, Ast.PaId (_loc, Ast.IdLid (_loc, "self")),
                    Ast.CrSem (_loc,
                      Ast.CrInh (_loc,
                        Ast.CeApp (_loc,
                          Ast.CeApp (_loc,
                            Ast.CeApp (_loc,
                              Ast.CeApp (_loc,
                                Ast.CeCon (_loc, Ast.BFalse,
                                  Ast.IdLid (_loc, "root_config"),
                                  Ast.TyNil _loc),
                                Ast.ExId (_loc, Ast.IdLid (_loc, "srcs"))),
                              Ast.ExId (_loc, Ast.IdLid (_loc, "dest"))),
                            Ast.ExId (_loc, Ast.IdLid (_loc, "data"))),
                          Ast.ExId (_loc, Ast.IdLid (_loc, "defaults"))),
                        "super"),
                      Ast.CrSem (_loc, sub_objects, accessors))))))))))
let main_si _loc cname decls =
  Ast.StSem (_loc, Ast.StOpn (_loc, Ast.IdUid (_loc, "Rascl")),
    Ast.StSem (_loc, Ast.StOpn (_loc, Ast.IdUid (_loc, "ConfigObject")),
      Ast.StSem (_loc, Ast.StOpn (_loc, Ast.IdUid (_loc, "Dict")),
        Ast.StSem (_loc,
          Ast.StVal (_loc, Ast.BFalse,
            Ast.BiEq (_loc, Ast.PaId (_loc, Ast.IdLid (_loc, "defaults")),
              Ast.ExApp (_loc, Ast.ExId (_loc, Ast.IdLid (_loc, "create")),
                Ast.ExId (_loc, Ast.IdUid (_loc, "()"))))),
          Ast.StSem (_loc, Ast.StExp (_loc, top_doin_expr _loc [] decls),
            rootconf_si loc cname decls)))))