Commits

camlspotter committed 65e7e94

cleanup and comments

Comments (0)

Files changed (3)

typing/dispatch.ml

   }
 
   module Stack : sig 
+
     val enter : (unit -> 'a) -> 'a * t list
+      (** [enter f] enters an let polymorphism and do [f ()].
+	  It returns the result of [f ()] and dispatches
+	  added in the let.
+      *)
+
     val rev_add : t list -> unit
+      (** add dispatches *)
+
   end = struct
     let dispatches : t list ref = ref []
     let pushed = ref []
 
-    (* CR jfuruse: top is really really really dirty hack.  We must call [push
-       ~top:true ()] before entering the top push-let-pop *)
     let push () = 
       pushed := !dispatches :: !pushed; dispatches := []
+
     let pop () =
       let disps = !dispatches in
       match !pushed with
   end
 
   (* Note when folding arrows: a crazy magic is used in
-     ocamlbuild/discard_printf.mll, whose type is ('a -> 'b as 'b).  Therefore,
-     naive folding may fall into infinite loops *)
-  let rec fold_arrow visited env f st ty =
-    let ty = expand_head env ty in
-    match ty.desc with
-    | Tarrow (l, t, u, c) when not (List.memq ty visited) ->
-        fold_arrow (ty :: visited) env f (f st ty l t c) u
-    | _ -> st, ty
+     ocamlbuild/discard_printf.mll, whose type is ('a -> 'b as 'b).  
+     Therefore, naive folding may fall into infinite loops *)
+  let fold_arrow env = 
+    let rec fold_arrow visited env f st ty =
+      let ty = expand_head env ty in
+      match ty.desc with
+      | Tarrow (l, t, u, c) when not (List.memq ty visited) ->
+          fold_arrow (ty :: visited) env f (f st ty l t c) u
+      | _ -> st, ty
+    in
+    fold_arrow [] env
+  ;;
 
-  let fold_arrow env = fold_arrow [] env
 
-  (* [new_env] is an environment created by the original OCaml typing w/o
-     implicit $-arrows. We must fix this [new_env] from [env] by attaching
-     them. *)
-  let add_typed_patterns ~env ~new_env pats abstracts_list =
-    (* CR jfuruse: annotations *)
-    List.fold_left2 (fun env pat abstracts ->
-      (* If there is no $-abst, we should use one in [new_env]. NOTE: Not use
-         [pat.pat_type], since polyvars may have different types in [new_env]
-         and [pat], ex.:
+  (* [env] is the initial type environment to type patterns.
+     After the typing [new_env] and [pat] are obtained.
+     [add_typed_patterns] extends [env] with [pat], adding 
+     implicit $-arrows if necessary. *)
+  let add_typed_patterns ~env ~new_env pats =
+    List.fold_left (fun env pat ->
+      (* NOTE: Do not use [pat.pat_type] but the type in [new_env],
+	 since polyvars may have different types between them.
+	 Ex:
            let (`A as x) = `A in ...
          Here x's
            type in new_env : [> `A]
               Env.find_value (Path.Pident id) new_env
             in
             let val_in_env = 
-              (* CR jfuruse: quick workaround *)
-              (* CR jfuruse: sound ? *)
+              (* CR jfuruse: is (==) correct ? *)
               if
                 val_in_new_env.val_type == pat.pat_type
                 || match (repr pat.pat_type).desc with
         | _ -> ()
       in
       iter pat;
-      !env) env pats abstracts_list
+      !env) env pats
 
   let rec pattern_may_have_implicit_dabst p =
     match p.ppat_desc with
     | Ppat_record _ | Ppat_array _ | Ppat_type _ | Ppat_lazy _ 
     | Ppat_or _ -> false
 
+  (* get $-absted argument types in [ty], reversed *)	
   let rev_dabsts env ty = 
     fold_arrow env (fun st _ty l t _c ->
       if is_dispatch l then (l, t) :: st else st)
       [] ty
 
+  (* get $-absted argument types in [ty] *)	
   let dabsts env ty =
     let rev_dabsts, rty = rev_dabsts env ty in
     List.rev rev_dabsts, rty
 
+  (* unify two types [dty] and [typ], considering [dty] may have 
+     $-arrows which are implicit and hidden in [typ]. 
+     After finding implicit $-arrows, [unifer] is used to unify
+     the types.
+  *)
   let unify_with_dispatch env dty typ unifier =
-    (* dty may have more *outmost* $-arrows than typ *)
+    (* dty may have outer $-arrows than typ *)
     let dty_rev_dabsts, _ = rev_dabsts env dty in
     let typ_rev_dabsts, _ = rev_dabsts env typ in
 
       in
       filter dty_rev_dabsts typ_rev_dabsts
     in
-(*
-  let implicit_dabsts =
-      List.filter (fun lty -> 
-        not (List.exists (equal lty) typ_dabsts)) dty_dabsts
-    in
-*)
     let typ = 
       List.fold_right (fun (l,t) st ->
         newty (Tarrow (l, t, st, Cok))) implicit_dabsts typ 

typing/dispatch.mli

     env:Env.t
     -> new_env:Env.t
     -> pattern list
-    -> _ list list
     -> Env.t
 
   val pattern_may_have_implicit_dabst : Parsetree.pattern -> bool 

typing/typecore.ml

     pat_list;
 
   (* rebuild new_env since $absts may be introduced *)
-  let new_env = Dispatch.add_typed_patterns ~env ~new_env pat_list abstracts_list in
+  (* CR jfuruse : abstract_list is no longer used *)
+  let new_env = Dispatch.add_typed_patterns ~env ~new_env pat_list in
   
   (List.combine pat_list exp_list, new_env)