Re: [Caml-list] First order compile time functorial polymorphism in Ocaml

["Jacques Carette" <carette@mcmaster.ca>]

I most certainly would welcome such a set of tools for reuse.

Has anyone seriously looked (from an ML point of view) at the "scrap your boilerplate" paper from the Haskell crowd ?

When faced with the following issue myself for a 'monster' algebraic datatype (but containing no negatives), I wrote 
the code found below.  I would welcome any and all criticisms of it [the code works and is useful, but is doubtless a 
horrible hack].

Jacques

(* part of a toy interpreted for a Maple-like language *)
open Maple;;

let rec generic_traverse filter f x = 
    let traverse r = generic_traverse filter f r in
    let activate z = if filter z then f z else z in
    let tt = function
    | Mint x as z -> activate z
    | Mbool x as z -> activate z
    | Mfloat(x,y) as z -> activate z
    | Mname x as z -> activate z
    | Mstring x as z -> activate z
    | Mlocal x as z -> activate z
    | Mexport x as z -> activate z
    | Mparam x as z -> activate z
    | Msum x -> activate(Msum (List.map traverse x))
    | Mprod x -> activate(Mprod (List.map traverse x))
    | Mpow(x,y) -> activate(Mpow(traverse x, traverse y))
    | Mcomp(o,x,y) -> activate(Mcomp(o, traverse x, traverse y))
    | Mtableref(n,i) -> activate(Mtableref( traverse n, List.map traverse i))
    | Mnot x -> activate(Mnot(traverse x))
    | Mand(x,y) -> activate(Mand(traverse x, traverse y))
    | Mor(x,y) -> activate(Mor(traverse x, traverse y))
    | Mxor(x,y) -> activate(Mxor(traverse x, traverse y))
    | Mimplies(x,y) -> activate(Mimplies(traverse x, traverse y))
    | Mrange(x,y) -> activate(Mrange(traverse x, traverse y))
    | Mproc x -> 
        let f = function
            | None -> None
            | Some z -> Some(traverse z) in
        let y=f x.mresult_type in 
        activate(Mproc( {
            mparams = List.map traverse x.mparams;
            mresult_type = y;
            mlocals = List.map traverse x.mlocals;
            mclosure = x.mclosure; (* do not traverse the closure! *)
            moptions = List.map traverse x.moptions;
            mdescription = List.map traverse x.mdescription;
            mbody = List.map traverse x.mbody
            } ))
    | Mmodule x -> activate(Mmodule( {
        mmod_params = List.map traverse x.mmod_params;
        mmod_locals = List.map traverse x.mmod_locals;
        mmod_exports = List.map traverse x.mmod_exports;
        mmod_closure = x.mmod_closure; (* do not traverse the closure! *)
        mmod_options = List.map traverse x.mmod_options;
        mmod_description = List.map traverse x.mmod_description;
        mbody_of_module = List.map traverse x.mbody_of_module
        } ))
    | Mfunc(n,i) -> activate(Mfunc( traverse n, List.map traverse i))
    | Mforfrom(i,ifrom,ito,iby,iwhile,body) ->
            activate(Mforfrom(traverse i, traverse ifrom, traverse ito,
                traverse iby, traverse iwhile, List.map traverse body))
    | Mforin(i,iin,iwhile,body) ->
            activate(Mforin(traverse i, traverse iin, traverse iwhile,
                List.map traverse body))
    | Mreturn x -> activate(Mreturn(traverse x))
    | Merror x -> activate(Merror(traverse x))
    | Mread x -> activate(Mread(traverse x))
    | Muneval x -> activate(Muneval(traverse x))
    | Msave x -> activate(Msave(List.map traverse x))
    | Mdcolon(x,y) -> activate(Mdcolon(traverse x, traverse y))
    | Massign(x,y) -> activate(Massign(List.map traverse x, List.map traverse y))
    | Mseq x -> activate(Mseq(List.map traverse x))
    | Mlist x -> activate(Mlist(List.map traverse x))
    | Mif (x,y,z) -> activate(Mif( (traverse x), (traverse y), (traverse z) ))
    | Mstatseq x -> activate(Mstatseq(List.map traverse x))
    (*| _ as x -> activate x *)
    in
    tt x
      ;;

(* example [fake] use *)

let filt = function
     | Mlist _ | Mseq _ -> true
     | _ -> false
and
     do_something = function
     | Mlist x -> List.map Simpl.flatten x
     | Mseq x -> List.map Simpl.flatten2 x
     | _ -> raise CannotHappenButCompilerCantKnowIt ;;

generic_traverse filt do_something my_maple_dag;;


-------------------
To unsubscribe, mail caml-list-request@inria.fr Archives: http://caml.inria.fr
Bug reports: http://caml.inria.fr/bin/caml-bugs FAQ: http://caml.inria.fr/FAQ/
Beginner's list: http://groups.yahoo.com/group/ocaml_beginners