Commits

camlspotter committed cb064d5

classes are named and now easier to compose

Comments (0)

Files changed (4)

 module StringSet = Set.Make(struct type t = string let compare (x : string) y = compare x y end)
 module StringMap = Map.Make(struct type t = string let compare (x : string) y = compare x y end)
 
+let group_names prefix decls =
+  List.map (function 
+    | TyDcl (_, name, _, _, _) -> prefix ^ name
+    | _ -> assert false) decls
+
+let make_classes ~virt params prefix decls the_clexpr =
+  let names = group_names prefix decls in
+  match names with
+  | [] -> assert false
+  | name :: names ->
+      make_class
+        (make_class_eq ~virt params <:ident<$lid:name$>> the_clexpr
+         :: List.map (fun n ->
+           make_class_eq ~virt params <:ident<$lid:n$>>
+           <:class_expr< $lid:name$ >>) names
+        )
+
 module Visitor = struct
 
   let used = ref StringMap.empty
             <:class_str_item< method virtual $name$ : $method_type params name$ >> :: st) vmethods []
       in
       let methods = concat_class_str_items (vmethods @ methods) in
-      if vmethods <> [] then
-        <:str_item< class virtual ovisit = object (self:'self) $methods$ end >>
-      else
-        <:str_item< class ovisit = object (self:'self) $methods$ end >>
+
+      (* We use the name of the first type for the class name prefix *)
+      make_classes ~virt:(vmethods <> []) []
+        "ovisit_" decls 
+        <:class_expr<object (self:'self) $methods$ end>>
     )
   ;;
 end
             <:class_str_item< method virtual $name$ : $method_type params name$ >> :: st) vmethods []
       in
       let methods = concat_class_str_items (vmethods @ methods) in
-      if vmethods <> [] then
-        <:str_item< class virtual ['st] ofold = object (self) $methods$ end >>
-      else
-        <:str_item< class ['st] ofold = object (self) $methods$ end >>
+
+      (* We use the name of the first type for the class name prefix *)
+      make_classes ~virt:(vmethods <> []) [ <:ctyp<'st>> ]
+        "ofold_" decls 
+        <:class_expr<object (self) $methods$ end>>
     )
   ;;
 end
             <:class_str_item< method virtual $name$ : $method_type params name$ >> :: st) vmethods []
       in
       let methods = concat_class_str_items (vmethods @ methods) in
-      if vmethods <> [] then
-        <:str_item< class virtual omap = object (self:'self) $methods$ end >>
-      else
-        <:str_item< class omap = object (self:'self) $methods$ end >>
+
+      make_classes ~virt:(vmethods <> []) []
+        "omap_" decls 
+        <:class_expr<object (self:'self) $methods$ end>>
+
     )
-  ;;
+
+
 end
 
 
          crSem_of_list (List.map (fun (l,e) -> <:class_str_item< method $l$ = $e$ >>) label_exprs))
 
 
+(** { 6 Misc } *)
 
+(** These are helper functions which require easier program construction
+    in Original syntax *)
+
+let make_class_eq ?(loc=_loc) ?(virt=false) vars ident clexpr =
+    CeEq (loc, 
+          CeCon (loc, (if virt then ViVirtual else ViNil), ident, tyCom_of_list vars),
+          clexpr)
+
+let make_class class_defs = StCls (_loc, ceAnd_of_list class_defs)
 val strip_ident_loc : ident -> ident
 (** strip location *)
 
+(** { 6 Misc } *)
 
+(** These are helper functions which require easier program construction
+    in Original syntax *)
+
+val make_class_eq : 
+  ?loc:Loc.t 
+  -> ?virt:bool 
+  -> ctyp list  (** params *)
+  -> ident 
+  -> class_expr  (** after = *)
+  -> class_expr
+(** make (virtual) ['a,..,'z] id = ... *)
+
+val make_class : class_expr list ->str_item
+(** class ... and ... *)
 
 (** { 6 Error } *)
 
 with ovisit
 
 class o' = object (self:'self)
-  inherit ovisit
+  inherit ovisit_t
   val mutable st = 0
   method st = st
   method int n = st <- st + n; self