Commits

camlspotter committed 9e5e42a

traverse function

Comments (0)

Files changed (1)

typing/typecore.ml

   node
 ;;
 
-(* Quick hack for confusing indents *)
-let check_pattern_indents pexp (pat_a_list : (Parsetree.pattern * 'a) list) =
-  match pat_a_list with
-  | [] -> ()
-  | (pat,_) :: pat_a_list ->
-      let bol_of_loc loc = 
-	let (_, _, pos) = Location.get_pos_info loc.Location.loc_start in
-	pos
-      in
-      let bol_start = bol_of_loc pat.ppat_loc in
-      List.iter (fun (pat,_) ->
-	(* CR jfuruse: TAB count failure *)
-	if bol_of_loc pat.ppat_loc < bol_start 
-	  && bol_of_loc pat.ppat_loc - 2 (* = String.length "| " *) < bol_of_loc pexp.pexp_loc
-	then
-	  Location.prerr_warning pat.ppat_loc Warnings.Confusing_indent)
-	pat_a_list
+module Checkpos = struct
 
-let check_if_indent pexp1 pexp2 =
-  match pexp1.pexp_desc with
-  | Pexp_ifthenelse (_, _, None) ->
-      let bol_of_loc loc = 
-	let (_, _, pos) = Location.get_pos_info loc.Location.loc_start in
-	pos
-      in
-      let bol_start = bol_of_loc pexp1.pexp_loc in
-      if bol_of_loc pexp2.pexp_loc > bol_start then
-	Location.prerr_warning pexp2.pexp_loc Warnings.Confusing_indent
-  | _ -> ()
+  (* CR jfuruse: already warned switch should be mutable field of constr *)
+  type constr = {
+    eq_or_right : (int * bool) option;
+    eq_or_left : (int * bool) option;
+    sequence_eq_or_left : (int * bool) option; (* never inherited into subexps *)
+  }
+
+  let empty = { eq_or_right = None; eq_or_left = None; sequence_eq_or_left = None }
+
+  let eq_or_left constr n = 
+    match constr.eq_or_left with
+    | None -> { constr with eq_or_left = Some (n, false) }
+    | Some (m, _) when n < m -> { constr with eq_or_left = Some (n, false) }
+    | Some _ -> constr
+
+  let sequence_eq_or_left constr n = 
+    match constr.sequence_eq_or_left with
+    | None -> { constr with sequence_eq_or_left = Some (n, false) } 
+    | Some (m, _) when n < m -> { constr with sequence_eq_or_left = Some (n, false) } 
+    | Some _ -> constr
+
+  let eq_or_right constr n = 
+    match constr.eq_or_right with
+    | None -> { constr with eq_or_right = Some (n, false) }
+    | Some (m, _) when m < n -> { constr with eq_or_right = Some (n, false) }
+    | Some _ -> constr
+
+  let get_pos loc = 
+    let (_,_,pos) = Location.get_pos_info loc.Location.loc_start in
+    pos
+
+  let get_line loc = 
+    let (_,line,_) = Location.get_pos_info loc.Location.loc_start in
+    line
+
+  let iter_opt f = function
+    | None -> ()
+    | Some v -> f v
+
+  let iter_snds f l = List.iter (fun (_,e) -> f e) l
+ 
+  let rec check constr pexp = 
+    let loc = pexp.pexp_loc in
+    let pos = get_pos loc in
+    let constr = match constr.eq_or_right with
+      | None | Some (_, true) -> constr
+      | Some (eq_or_right, false) -> 
+	  if pos < eq_or_right then begin
+	    Location.prerr_warning loc Warnings.Confusing_indent;
+	    { constr with eq_or_right = Some (eq_or_right, true) }
+	  end else constr
+    in
+    let constr = match constr.eq_or_left with
+      | None | Some (_, true) -> constr
+      | Some (eq_or_left, false) -> 
+	  if eq_or_left < pos then begin
+	    Location.prerr_warning loc Warnings.Confusing_indent;
+	    { constr with eq_or_left = Some (eq_or_left, true) }
+	  end else constr
+    in
+    (* CR jfuruse: no need of updating the boolean *)
+    let constr = match constr.sequence_eq_or_left with
+      | None | Some (_, true) -> constr
+      | Some (sequence_eq_or_left, false) -> 
+	  if sequence_eq_or_left < pos then begin
+	    Location.prerr_warning loc Warnings.Confusing_indent;
+	    { constr with sequence_eq_or_left = Some (sequence_eq_or_left, true) }
+	  end else constr
+    in
+    let constr = { constr with sequence_eq_or_left = None } in
+    match pexp.pexp_desc with
+    | Pexp_ident _ -> ()
+    | Pexp_constant _ -> ()
+    | Pexp_let (_, pexps, e) -> 
+	(* defs do not inherit constr *)
+	iter_snds (check empty) pexps;
+	(* body must occur right of the let *)
+	check (eq_or_right constr pos) e
+    | Pexp_function ("", eopt, pexps) -> 
+	(* the real function -> *)
+	assert (eopt = None);
+	(* case exp must be right either the function or pat *)
+	List.iter (fun (pat, exp) ->
+	  let pos' = get_pos pat.ppat_loc in
+	  check (eq_or_right constr (min pos pos')) exp) pexps
+    | Pexp_function (_, eopt, pexps) -> 
+	(* it may be let f x = e *)
+	iter_opt (check empty) eopt;
+	iter_snds (check empty) pexps
+    | Pexp_apply (e, lexps) -> check constr e; iter_snds (check constr) lexps
+    | Pexp_match (e, pexps) -> 
+	check empty e;
+	(* case exp must be right either the function or pat *)
+	List.iter (fun (pat, exp) ->
+	  let pos' = get_pos pat.ppat_loc in
+	  check (eq_or_right constr (min pos pos')) exp) pexps
+    | Pexp_try (e, pexps) -> 
+	check empty e;
+	(* case exp must be right either the function or pat *)
+	List.iter (fun (pat, exp) ->
+	  let pos' = get_pos pat.ppat_loc in
+	  check (eq_or_right constr (min pos pos')) exp) pexps
+    | Pexp_tuple es -> List.iter (check constr) es
+    | Pexp_construct (_, eopt, _) -> iter_opt (check empty) eopt
+    | Pexp_variant (_, eopt) -> iter_opt (check empty) eopt
+    | Pexp_record (ies, eopt) -> 
+	iter_snds (check empty) ies; 
+	iter_opt (check empty) eopt
+    | Pexp_field (e, _) -> 
+	check constr e
+    | Pexp_setfield (e, _, e') -> 
+	check constr e;
+	check constr e'
+    | Pexp_array es -> 
+	List.iter (check empty) es
+    | Pexp_ifthenelse (e1, e2, eopt) -> 
+	check empty e1;
+	let constr = eq_or_right constr pos in
+	(* then must appear right of if *)
+	check constr e2;
+	(* else must appear right of if *)
+	iter_opt (check constr) eopt
+    (* e1; e2; e3 => e1; (e2; e3) *)
+    | Pexp_sequence (({ pexp_desc = ( Pexp_ifthenelse _ 
+                                    | Pexp_function _
+                                    | Pexp_let _
+				    | Pexp_match _
+                                    | Pexp_try _) } as e1), e2) ->
+	check constr e1;
+	(* e2 must appear left of if/function/let/match/try *)
+	check (sequence_eq_or_left constr (get_pos e1.pexp_loc)) e2
+    | Pexp_sequence (e1, e2) ->
+	check constr e1;
+	(* if e2 is in the different line of e1, e2 must appear left of e1 (or the same ?) *)
+	if get_line e1.pexp_loc <> get_line e2.pexp_loc then
+	  check (sequence_eq_or_left constr (get_pos e1.pexp_loc)) e2
+	else check empty e2
+    | Pexp_while(e1, e2) -> 
+	check empty e1;
+	check empty e2
+    | Pexp_for (_, e1, e2, _, e3) ->
+	check empty e1;
+	check empty e2;
+	check empty e3
+    | Pexp_constraint (e, _, _) -> 
+	check empty e
+    | Pexp_when (e1, e2) ->
+	(* e2 must inherit the pattern match constr *)
+	check empty e1;
+	check constr e2
+    | Pexp_send (e, _) ->
+	check constr e
+    | Pexp_new _ -> ()
+    | Pexp_setinstvar (_, e) ->
+	check constr e
+    | Pexp_override lexps ->
+	iter_snds (check empty) lexps
+    | Pexp_letmodule (_, _mexp, e) ->
+	(* CR jfuruse; TODO _mexp *)
+	check constr e
+    | Pexp_assert e ->
+	check constr e
+    | Pexp_assertfalse -> ()
+    | Pexp_lazy e ->
+	check constr e
+    | Pexp_poly (e, _) -> 
+	check empty e
+    | Pexp_object _class_structure ->
+	(* CR jfuruse: TODO *)
+	()
+end
 
 (* Typing of constants *)
 
         exp_type = ty_res;
         exp_env = env }
   | Pexp_match(sarg, caselist) ->
-      check_pattern_indents sexp caselist;
       let arg = type_exp env sarg in
       let ty_res = newvar() in
       let cases, partial =
             exp_env = env }
       end
   | Pexp_sequence(sexp1, sexp2) ->
-      check_if_indent sexp1 sexp2;
       let exp1 = type_statement env sexp1 in
       let exp2 = type_exp env sexp2 in
       re {
         exp_type = body.exp_type;
         exp_env = env }
   | Pexp_sequence(sexp1, sexp2) ->
-      check_if_indent sexp1 sexp2;
       let exp1 = type_statement env sexp1 in
       let exp2 = type_expect env sexp2 ty_expected in
       re {
       in
       type_expect ?in_function env sfun ty_expected
   | Pexp_function (l, _, caselist) ->
-      check_pattern_indents sexp caselist;
       let (loc, ty_fun) =
         match in_function with Some p -> p
         | None -> (sexp.pexp_loc, ty_expected)
 let type_expression env sexp =
   Typetexp.reset_type_variables();
   begin_def();
+  Checkpos.check Checkpos.empty sexp;
   let exp = type_exp env sexp in
   end_def();
   if is_nonexpansive exp then generalize exp.exp_type