Commits

camlspotter committed e6b0c0c

omap fix

Comments (0)

Files changed (3)

+===================================================================================
+pa_ovisitor : auto-generation of visitor, folder and mapper from type definitions
+===================================================================================
+
+pa_ovisitor is CamlP4/Type_conv module to auto-generate visitor, folder
+and mapper pattern codes from type definitions. pa_ovisitor auto-creates
+skelton classes for visitor, folder and mapper of data types. Users can 
+extend these skeltons using class inheritance open-recursively.
+
+Visitor auto-generation
+=============================
+
+Let's start a small example to see how it works::
+
+    type t = 
+      | Foo of int list 
+      | Bar of int * int
+    with ovisit
+
+A type definition is postfixed by ``with ovisit``. 
+
+Preprocess this code with CamlP4 and pa_ovisitor by 
+``camlp4o pa_type_conv.cma pa_ovisitor.cma -printer Camlp4OCamlPrinter source.ml``.
+(The source code must be saved as ``source.ml``, and the include directories
+(-I ...) for pa_type_conv.cma and pa_ovisitor.cma are omitted.).
+Then it should auto-create a class definition ``ovisit_t``
+with the following definition (you do not need to follow the entire code)::
+
+    class virtual ovisit_t =
+      object (self)
+        method virtual list : 'a1. ('a1 -> unit) -> 'a1 list -> unit
+        method virtual int : int -> unit
+        method t : t -> unit =
+          fun __value ->
+            match __value with
+            | Foo __x1 -> (self#list self#int __x1; ())
+            | Bar (__x1, __x2) -> (self#int __x1; self#int __x2; ())
+      end
+  
+This ``ovisit_t`` is a skelton class for the visitor pattern of the data type.
+It has methods with the same names of the data types appear in the type definition:
+``list``, ``int`` and ``t``. They are visitors for those types. The visitor method
+``t`` has type ``t -> unit``: it takes a value of type ``t`` and visit 
+its internal components.
+
+Extending skelton classes
+---------------------------------------------
+
+In method ``t``, the components
+of ``t`` are visited by the methods ``int`` and ``list`` which should visit
+``int`` and ``list`` data types. Note that methods ``int`` and ``list`` are
+virtual and no definitions are given. It is the user's responsibility to
+give the implementation of these virtual visitor methods. There are two ways
+of this: auto-generate underlying visitor methods by attaching ``with ovisit``
+to the definitions of the underlying types, or hand writing them.
+Since ``int`` and ``list`` are primitive types without type deinitions,
+we implement them by ourselves::
+
+    class c = object
+      inherit ovisit_t
+    
+      (* the state *)
+      val mutable st = 0
+      method st = st
+    
+      (* visitor *)
+      method int n = st <- st + n
+      method list = List.iter
+    end
+
+Here, the visitor methods for ``int`` and ``list`` are defined, inheriting
+the skelton class ``ovisit_t``. Note that the class also has a state ``st``.
+The ``int`` visitor accumulates the value to the states, and the ``list``
+visitor iterates the visitor function for the parameter type over the list elements.
+(See the type of the method ``list`` for details.)
+
+As a result the class ``c`` is a class to accumulates all the integers of 
+type ``t``::
+
+    let () = 
+      let o1 = new c in
+      o1#t (Foo [1;2;3;4;5]);
+      assert (o1#st = 15);
+      let o2 = new c in
+      o2#t (Bar (1,2)); 
+      assert (o2#st = 3)
+
+Composing visitors
+----------------------------------------
+
+The classes created by ``with ovisit`` only concretely define visitor methods
+which are defined mutually in the type definition. The visitor methods for
+the other data types which are defined outside of the definition are kept 
+virtual. In order to implement the complete visitor classes, you can hand-write 
+those virtual methods like above, or compose visitor classes by inheritance
+which is explained in this section.
+
+Now let's define a new data type ``u`` using ``t`` inside, 
+and generate its visitor::
+ 
+    type u = { t : t; children : u list } with ovisit
+
+The visitor skelton class ``ovisit_u`` has a virtual method ``t`` for the visitor
+of ``t``. We can use the visitor class ``c`` (or ``c_pure``) we have created above.
+The composition is done by inheritance::
+
+    class c_u = object
+      inherit c
+      inherit ovisit_u
+    end
+
+That's it. Now the method ``u`` of ``c_u`` accumulates all the integer occurrences
+in a value of type ``u``::
+
+    let () = 
+      let o1 = new c_u in
+      o1#u { t = Foo [1;2;3;4;5]; children = [] }; 
+      assert (o1#st = 15);
+      let o2 = new c_u in
+      o2#u { t = Bar (1,2); 
+             children = [ { t = Foo [1;2;3;4;5]; children = [] };
+                          { t = Bar (3,4); children = [] } ]
+           };
+      assert (o2#st = 25)
+
+
+Folder
+========================================
+
+``with ofold`` auto-generates folder: a functional version of visitor.
+It is like the relationship between List.iter and List.fold:
+a folder method takes an accumulator argument and traverses 
+data modifying the accumulator value and returns it as the result::
+
+    type t = 
+      | Foo of int list 
+      | Bar of int * int
+    with ofold
+  
+    class c = object
+      inherit [int] ofold_t (* requires the accumulator type *)
+    
+      method int st n = st + n
+      method list = List.fold_left
+    end
+  
+    let () = 
+      let o = new c in (* folder is pure, so we only need one o *)
+      assert ( o#t 0 (Foo [1;2;3;4;5]) = 15 );
+      assert ( o#t 0 (Bar (1,2)) = 3 ) 
+
+
+Mapper
+========================================
+
+Evaluation order 
+========================================
+
+The evaluation order of visitor/folder/mapper is depth first and 
+left-to-right, but you should avoid relying on it when you write 
+those methods by hand.
+
+NO_VISIT( typename, typename, ... )
+=======================================
+
+Sometimes it is desirable just to skip visiting some specific data types.
+Skipping visiting can be achieved by overriding the corresponding method
+with NOP method::
+
+    class o = object (self:'self)
+        inherit ovisit_x
+
+        method int _ = self (* Just ignore it *)
+    end
+
+There is another way. Declaring data type names which should not be visited
+by ``NO_VISIT(...)`` toplevel expression. The data types in ``NO_VISIT(...)``
+are excluded from the next ``with ovisit/ofold/omap`` auto-generation and
+it creates classes without the corresponding methods. Those data types are
+simply skipped in visiting process::
+
+    NO_VISIT(bool, list)
+
+    type t = ... bool ... list ... with ovisit
+
+The class ``ovisit_t`` does not have method ``bool`` and ``list``.
+Booleans and any list element in data type ``t`` is not visited by
+``ovisit_t``.
+
+``NO_VISIT(...)`` also applies to ``with ofold`` and ``with omap``.
+For ``ofold`` no visit data types are just skiped as ``ovisit`` no visits.
+For ``omap``, the values of no visit data types are kept as they are.
+
+The effect of ``NO_VISIT(...)`` is only available at the next pa_ovisitor annotation. At each ``with ovisit/ofold/omap``, the set of no visit data types are reset to the empty.
+

pa/pa_ovisitor.ml

         | None -> None
         | Some f -> 
             Some (Gen.apply loc f (List.map (fun x -> match gen_ctyp x with 
-            | None -> <:expr<fun st _ -> st>> 
+            | None -> <:expr<fun __st _ -> __st>> 
             | Some f -> f ) args))
         end
     | TyApp (loc, TyApp (_loc, f, args1), args2) -> 
     | TyTup (loc, ctyp) ->
         let ctyps = list_of_ctyp ctyp [] in
         let ids = mk_idents "__tup" (List.length ctyps) in
-        Some (<:expr<fun st -> 
+        Some (<:expr<fun __st -> 
           $ Gen.abstract loc [ PaTup (loc, paCom_of_list (List.map patt_of_id ids)) ]
             (gen_let_seq ctyps (List.map expr_of_id ids)) $ >> )
     | _ -> assert false
   
   and gen_let_seq ctyps exps = match ctyps, exps with
-    | [], [] -> <:expr< st >>
+    | [], [] -> <:expr< __st >>
     | (ctyp::ctyps), (exp::exps) ->
         begin match gen_ctyp ctyp with
         | None -> gen_let_seq ctyps exps
-        | Some f -> <:expr< let st = $f$ st $exp$ in $ gen_let_seq ctyps exps $ >>
+        | Some f -> <:expr< let __st = $f$ __st $exp$ in $ gen_let_seq ctyps exps $ >>
         end
     | _ -> assert false
   
     | Some f -> f
   
   let is_just_self_case = function
-    | <:match_case< $_$ -> st >> -> true
+    | <:match_case< $_$ -> __st >> -> true
     | _ -> false
   
   let sum _name _loc ctyp = 
       let ids = mk_idents "__x" (List.length ctyps) in
       let patt = create_patt_app (PaId(locId, id)) (List.map patt_of_id ids) in
       let exp = match ids with
-        | [] -> <:expr< st >>
+        | [] -> <:expr< __st >>
         | _ -> gen_let_seq ctyps (List.map expr_of_id ids)
       in
       <:match_case@locOf< $ patt $ -> $ exp $ >>
       ) constrs 
     in
     if List.for_all is_just_self_case cases then
-      <:expr< fun st __value -> st >>
+      <:expr< fun __st __value -> __st >>
     else
-      <:expr< fun st __value -> match __value with $mcOr_of_list cases$ >>
+      <:expr< fun __st __value -> match __value with $mcOr_of_list cases$ >>
   
   let record _name _loc ctyp = 
     let get_lab cty = match strip_field_flags cty with
       | _ -> assert false) ctyps)
     in
     let mems = List.map (fun l -> <:expr< __value.$id:l$ >> ) labs in 
-    <:expr< fun st __value -> $gen_let_seq ctyps mems $ >>
+    <:expr< fun __st __value -> $gen_let_seq ctyps mems $ >>
     
   (** for [X; Y; .. ] and BASE, build ('st -> X -> 'st) -> ('st -> Y -> 'st) -> ... -> BASE *)
   let dispatch_type params base = 
         | None -> None
         | Some f -> 
             Some (Gen.apply loc f (List.map (fun x -> match gen_ctyp x with 
-            | None -> <:expr<fun self v -> self, v >> 
-            | Some f -> <:expr< fun self -> $f$ >> ) args))
+            | None -> <:expr<fun __st v -> __st, v >> 
+            | Some f -> f ) args))
         end
     | TyApp (loc, TyApp (_loc, f, args1), args2) -> 
         gen_ctyp (TyApp (loc, f, TyCom(_loc, args1, args2)))
             List.fold_right (fun p e -> <:expr< $p$ && $e$ >>) (List.tl preds) (List.hd preds)
           in
           let final = <:expr< if $modifiedp$ then __value else $ final_modified $ >> in
-          let e, modified = gen_letx_seq ctyps (List.map expr_of_id xs) (List.map patt_of_id ys) <:expr< self, $final$ >> in
-          if modified then e else <:expr< self, __value >>
+          let e, modified = gen_letx_seq ctyps (List.map expr_of_id xs) (List.map patt_of_id ys) <:expr< __st, $final$ >> in
+          if modified then e else <:expr< __st, __value >>
         in
         Some (Gen.abstract loc [ patt ] exp)
 
         | None -> 
             <:expr< let $pat$ = $exp$ in $ e $ >>, modified
         | Some f -> 
-            <:expr< let self, $pat$ = $f$ $exp$ in $ e $>>, true
+            <:expr< let __st, $pat$ = $f$ __st $exp$ in $ e $>>, true
         end
     | _ -> assert false
   
   let alias _name _loc cty = 
     match gen_ctyp cty with
     | None -> <:expr< >>
-    | Some f -> <:expr< fun __value -> $f$ __value >>
+    | Some f -> f
   
   let is_just_self_case = function
-    | <:match_case< $_$ -> self, __value >> -> true
+    | <:match_case< $_$ -> __st, __value >> -> true
     | _ -> false
   
   let sum _name _loc ctyp = 
       let ys = mk_idents "__y" (List.length ctyps) in
       let patt = create_patt_app (PaId(locId, id)) (List.map patt_of_id xs) in
       let exp = match xs with
-        | [] -> <:expr< self, __value >>
+        | [] -> <:expr< __st, __value >>
         | _ -> 
             let final_modified = create_expr_app (ExId(locId, id)) (List.map expr_of_id ys) in
             let modifiedp = 
               List.fold_right (fun p e -> <:expr< $p$ && $e$ >>) (List.tl preds) (List.hd preds)
             in
             let final = <:expr< if $modifiedp$ then __value else $ final_modified $ >> in
-            let e, modified =gen_letx_seq ctyps (List.map expr_of_id xs) (List.map patt_of_id ys) <:expr< self, $final$ >> in
-            if modified then e else <:expr< self, __value >> 
+            let e, modified = gen_letx_seq ctyps (List.map expr_of_id xs) (List.map patt_of_id ys) <:expr< __st, $final$ >> in
+            if modified then e else <:expr< __st, __value >> 
       in
       <:match_case@locOf< $ patt $ -> $ exp $ >>
     in
       ) constrs 
     in
     if List.for_all is_just_self_case cases then
-      <:expr< fun __value -> self, __value >>
+      <:expr< fun __st __value -> __st, __value >>
     else
-      <:expr< fun __value -> match __value with $mcOr_of_list cases$ >>
+      <:expr< fun __st __value -> match __value with $mcOr_of_list cases$ >>
   
   let record _name _loc ctyp = 
     let get_lab cty = match strip_field_flags cty with
         List.fold_right (fun p e -> <:expr< $p$ && $e$ >>) (List.tl preds) (List.hd preds)
       in
       let final = <:expr< if $modifiedp$ then __value else $ final_modified $ >> in
-      <:expr< self, $final$ >>
+      <:expr< __st, $final$ >>
     in
     let e, modified = 
       gen_letx_seq ctyps (List.map (fun l -> <:expr< __value.$id:l$ >>) labs)
                           (List.map (fun l -> <:patt< $id:l$ >>) labs) exp 
     in
-    <:expr< fun __value -> $ if modified then e else <:expr< self, __value >> $ >>
+    <:expr< fun __st __value -> $ if modified then e else <:expr< __st, __value >> $ >>
     
-  (** for [X; Y; .. ] and BASE, build ('self -> X -> 'self * X) -> ('self -> Y -> 'self * Y) -> ... -> BASE *)
+  (** for [X; Y; .. ] and BASE, build ('st -> X -> 'st * X) -> ('st -> Y -> 'st * Y) -> ... -> BASE *)
   let dispatch_type params base = 
-    List.fold_right (fun ctyp st -> <:ctyp< ('self -> $ctyp$ -> 'self * $ctyp$) -> $st$ >>) params base
+    List.fold_right (fun ctyp st -> <:ctyp< ('st -> $ctyp$ -> 'st * $ctyp$) -> $st$ >>) params base
   
   let method_type params name = 
     create_for_all params (dispatch_type params 
-                      <:ctyp< $ create_param_type params name $ 
-                              -> 'self * $ create_param_type params name $ >>)
+                      <:ctyp< 'st -> $ create_param_type params name $ 
+                              -> 'st * $ create_param_type params name $ >>)
   
   
   (******************* kind of template *)
 
       no_visit_idents := [];
 
-      make_classes ~virt:(vmethods <> []) []
+      make_classes ~virt:(vmethods <> []) [ <:ctyp<'st>> ]
         "omap_" decls 
-        <:class_expr<object (self:'self) $methods$ end>>
+        <:class_expr<object (self) $methods$ end>>
 
     )
 

pa/test/test_readme.ml

+type t = 
+  | Foo of int list 
+  | Bar of int * int
+with ovisit
+
+class c = object
+  inherit ovisit_t
+
+  (* the state *)
+  val mutable st = 0
+  method st = st
+
+  (* visitor *)
+  method int n = st <- st + n
+  method list = List.iter
+end
+
+
+let () = 
+  let o1 = new c in
+  o1#t (Foo [1;2;3;4;5]);
+  assert (o1#st = 15);
+  let o2 = new c in
+  o2#t (Bar (1,2)); 
+  assert (o2#st = 3)
+
+type u = { t : t; children : u list } with ovisit
+
+class c_u = object
+  inherit c
+  inherit ovisit_u
+end
+
+let () = 
+  let o1 = new c_u in
+  o1#u { t = Foo [1;2;3;4;5]; children = [] }; 
+  assert (o1#st = 15);
+  let o2 = new c_u in
+  o2#u { t = Bar (1,2); 
+         children = [ { t = Foo [1;2;3;4;5]; children = [] };
+                      { t = Bar (3,4); children = [] } ]
+       };
+  assert (o2#st = 25)
+
+module Fold = struct
+
+  type t = 
+    | Foo of int list 
+    | Bar of int * int
+  with ofold
+
+  class c = object
+    inherit [int] ofold_t
+  
+    method int st n = st + n
+    method list = List.fold_left
+  end
+
+  let () = 
+    let o = new c in (* folder is pure, so we only need one o *)
+    assert ( o#t 0 (Foo [1;2;3;4;5]) = 15 );
+    assert ( o#t 0 (Bar (1,2)) = 3 ) 
+
+end
+
+module Map = struct
+
+  type t = 
+    | Foo of u list 
+    | Bar of int * int
+
+  and u = { l : t list }
+  with omap
+
+  class c = object
+    inherit [int] omap_t
+  
+    method int st n = (st + n), n+1
+    method list f st xs = 
+      List.fold_left (fun (st,xs) x -> 
+        let st, x = f st x 
+        in st, x::xs) 
+        (st,[]) (List.rev xs)
+  end
+
+  let () = 
+    let o = new c in (* folder is pure, so we only need one o *)
+    assert ( o#t 0 (Foo [{l = [ Bar (1,2); Bar (3,4) ]}]) 
+             = (10, Foo [{l = [ Bar (2,3); Bar (4,5)]}]) );
+    assert ( o#t 0 (Bar (1,2)) = (3, Bar (2,3)) ) 
+
+end
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.