improve position handling for switches (closes #5656)

src/macro/interp.ml

@@ -4074,13 +4074,14 @@ and encode_expr e =
 			| EWhile (econd,e,flag) ->
 				16, [loop econd;loop e;VBool (match flag with NormalWhile -> true | DoWhile -> false)]
 			| ESwitch (e,cases,eopt) ->
-				17, [loop e;enc_array (List.map (fun (ecl,eg,e) ->
+				17, [loop e;enc_array (List.map (fun (ecl,eg,e,p) ->
 					enc_obj [
 						"values",enc_array (List.map loop ecl);
 						"guard",null loop eg;
-						"expr",null loop e
+						"expr",null loop e;
+						"pos",encode_pos p;
 					]
-				) cases);null encode_null_expr eopt]
+				) cases);null (fun (e,_) -> encode_null_expr e) eopt]
 			| ETry (e,catches) ->
 				18, [loop e;enc_array (List.map (fun (v,t,e,p) ->
 					enc_obj [
@@ -4382,9 +4383,9 @@ let rec decode_expr v =
 			EWhile (loop e1,loop e2,if flag then NormalWhile else DoWhile)
 		| 17, [e;cases;eo] ->
 			let cases = List.map (fun c ->
-				(List.map loop (dec_array (field c "values")),opt loop (field c "guard"),opt loop (field c "expr"))
+				(List.map loop (dec_array (field c "values")),opt loop (field c "guard"),opt loop (field c "expr"),maybe_decode_pos (field c "pos"))
 			) (dec_array cases) in
-			ESwitch (loop e,cases,opt decode_null_expr eo)
+			ESwitch (loop e,cases,opt (fun v -> decode_null_expr v,null_pos) eo)
 		| 18, [e;catches] ->
 			let catches = List.map (fun c ->
 				((decode_placed_name (field c "name_pos") (field c "name")),(decode_ctype (field c "type")),loop (field c "expr"),maybe_decode_pos (field c "pos"))

src/optimization/optimizer.ml

@@ -1713,9 +1713,9 @@ let optimize_completion_expr e =
 			map e
 		| ESwitch (e,cases,def) ->
 			let e = loop e in
-			let cases = List.map (fun (el,eg,eo) -> match eo with
+			let cases = List.map (fun (el,eg,eo,p) -> match eo with
 				| None ->
-					el,eg,eo
+					el,eg,eo,p
 				| Some e ->
 					let el = List.map loop el in
 					let old = save() in
@@ -1731,12 +1731,12 @@ let optimize_completion_expr e =
 					) el;
 					let e = loop e in
 					old();
-					el, eg, Some e
+					el, eg, Some e, p
 			) cases in
 			let def = match def with
 				| None -> None
-				| Some None -> Some None
-				| Some (Some e) -> Some (Some (loop e))
+				| Some (None,p) -> Some (None,p)
+				| Some (Some e,p) -> Some (Some (loop e),p)
 			in
 			(ESwitch (e,cases,def),p)
 		| ETry (et,cl) ->

src/syntax/ast.ml

@@ -368,7 +368,7 @@ and expr_def =
 	| EIn of expr * expr
 	| EIf of expr * expr * expr option
 	| EWhile of expr * expr * while_flag
-	| ESwitch of expr * (expr list * expr option * expr option) list * expr option option
+	| ESwitch of expr * (expr list * expr option * expr option * pos) list * (expr option * pos) option
 	| ETry of expr * (placed_name * type_hint * expr * pos) list
 	| EReturn of expr option
 	| EBreak
@@ -757,7 +757,7 @@ let map_expr loop (e,p) =
 	| EIn (e1,e2) -> EIn (loop e1, loop e2)
 	| EIf (e,e1,e2) -> EIf (loop e, loop e1, opt loop e2)
 	| EWhile (econd,e,f) -> EWhile (loop econd, loop e, f)
-	| ESwitch (e,cases,def) -> ESwitch (loop e, List.map (fun (el,eg,e) -> List.map loop el, opt loop eg, opt loop e) cases, opt (opt loop) def)
+	| ESwitch (e,cases,def) -> ESwitch (loop e, List.map (fun (el,eg,e,p) -> List.map loop el, opt loop eg, opt loop e, p) cases, opt (fun (eo,p) -> opt loop eo,p) def)
 	| ETry (e,catches) -> ETry (loop e, List.map (fun (n,t,e,p) -> n,type_hint t,loop e,p) catches)
 	| EReturn e -> EReturn (opt loop e)
 	| EBreak -> EBreak
@@ -790,12 +790,12 @@ let iter_expr loop (e,p) =
 		List.iter (fun (_,_,e,_) -> loop e) catches
 	| ESwitch(e1,cases,def) ->
 		loop e1;
-		List.iter (fun (el,eg,e) ->
+		List.iter (fun (el,eg,e,_) ->
 			exprs el;
 			opt eg;
 			opt e;
 		) cases;
-		(match def with None -> () | Some e -> opt e);
+		(match def with None -> () | Some (e,_) -> opt e);
 	| EFunction(_,f) ->
 		List.iter (fun (_,_,_,_,eo) -> opt eo) f.f_args;
 		opt f.f_expr
@@ -827,7 +827,7 @@ let s_expr e =
 		| EWhile (econd,e,NormalWhile) -> "while (" ^ s_expr_inner tabs econd ^ ") " ^ s_expr_inner tabs e
 		| EWhile (econd,e,DoWhile) -> "do " ^ s_expr_inner tabs e ^ " while (" ^ s_expr_inner tabs econd ^ ")"
 		| ESwitch (e,cases,def) -> "switch " ^ s_expr_inner tabs e ^ " {\n\t" ^ tabs ^ String.concat ("\n\t" ^ tabs) (List.map (s_case tabs) cases) ^
-			(match def with None -> "" | Some def -> "\n\t" ^ tabs ^ "default:" ^
+			(match def with None -> "" | Some (def,_) -> "\n\t" ^ tabs ^ "default:" ^
 			(match def with None -> "" | Some def -> s_expr_omit_block tabs def)) ^ "\n" ^ tabs ^ "}"
 		| ETry (e,catches) -> "try " ^ s_expr_inner tabs e ^ String.concat "" (List.map (s_catch tabs) catches)
 		| EReturn e -> "return" ^ s_opt_expr tabs e " "
@@ -899,7 +899,7 @@ let s_expr e =
 		if o then "?" else "" ^ n ^ s_opt_type_hint tabs t ":" ^ s_opt_expr tabs e " = "
 	and s_var tabs ((n,_),t,e) =
 		n ^ (s_opt_type_hint tabs t ":") ^ s_opt_expr tabs e " = "
-	and s_case tabs (el,e1,e2) =
+	and s_case tabs (el,e1,e2,_) =
 		"case " ^ s_expr_list tabs el ", " ^
 		(match e1 with None -> ":" | Some e -> " if (" ^ s_expr_inner tabs e ^ "):") ^
 		(match e2 with None -> "" | Some e -> s_expr_omit_block tabs e)

src/syntax/parser.ml

@@ -432,10 +432,10 @@ let reify in_macro =
 		| EWhile (e1,e2,flag) ->
 			expr "EWhile" [loop e1;loop e2;to_bool (flag = NormalWhile) p]
 		| ESwitch (e1,cases,def) ->
-			let scase (el,eg,e) p =
+			let scase (el,eg,e,_) p =
 				to_obj [("values",to_expr_array el p);"guard",to_opt to_expr eg p;"expr",to_opt to_expr e p] p
 			in
-			expr "ESwitch" [loop e1;to_array scase cases p;to_opt (to_opt to_expr) def p]
+			expr "ESwitch" [loop e1;to_array scase cases p;to_opt (fun (e,_) -> to_opt to_expr e) def p]
 		| ETry (e1,catches) ->
 			let scatch ((n,_),t,e,_) p =
 				to_obj [("name",to_string n p);("type",to_ctype t p);("expr",loop e)] p
@@ -1160,20 +1160,23 @@ and block2 name ident p s =
 				EBlock (block [e] s)
 
 and block acc s =
+	fst (block_with_pos acc null_pos s)
+
+and block_with_pos acc p s =
 	try
 		(* because of inner recursion, we can't put Display handling in errors below *)
 		let e = try parse_block_elt s with Display e -> display (EBlock (List.rev (e :: acc)),snd e) in
-		block (e :: acc) s
+		block_with_pos (e :: acc) (pos e) s
 	with
 		| Stream.Failure ->
-			List.rev acc
+			List.rev acc,p
 		| Stream.Error _ ->
 			let tk , pos = (match Stream.peek s with None -> last_token s | Some t -> t) in
 			(!display_error) (Unexpected tk) pos;
-			block acc s
+			block_with_pos acc pos s
 		| Error (e,p) ->
 			(!display_error) e p;
-			block acc s
+			block_with_pos acc p s
 
 and parse_block_elt = parser
 	| [< '(Kwd Var,p1); vl = parse_var_decls p1; p2 = semicolon >] ->
@@ -1442,10 +1445,10 @@ and parse_guard = parser
 
 and parse_switch_cases eswitch cases = parser
 	| [< '(Kwd Default,p1); '(DblDot,_); s >] ->
-		let b = (try block [] s with Display e -> display (ESwitch (eswitch,cases,Some (Some e)),punion (pos eswitch) (pos e))) in
+		let b,p2 = (try block_with_pos [] p1 s with Display e -> display (ESwitch (eswitch,cases,Some (Some e,punion p1 (pos e))),punion (pos eswitch) (pos e))) in
 		let b = match b with
-			| [] -> None
-			| _ -> Some ((EBlock b,p1))
+			| [] -> None,p1
+			| _ -> let p = punion p1 p2 in Some ((EBlock b,p)),p
 		in
 		let l , def = parse_switch_cases eswitch cases s in
 		(match def with None -> () | Some _ -> error Duplicate_default p1);
@@ -1454,12 +1457,14 @@ and parse_switch_cases eswitch cases = parser
 		(match el with
 		| [] -> error (Custom "case without a pattern is not allowed") p1
 		| _ ->
-			let b = (try block [] s with Display e -> display (ESwitch (eswitch,List.rev ((el,eg,Some e) :: cases),None),punion (pos eswitch) (pos e))) in
-			let b = match b with
-				| [] -> None
-				| _ -> Some ((EBlock b,p1))
+			let b,p2 = (try block_with_pos [] p1 s with Display e -> display (ESwitch (eswitch,List.rev ((el,eg,Some e,punion p1 (pos e)) :: cases),None),punion (pos eswitch) (pos e))) in
+			let b,p = match b with
+				| [] ->
+					let p2 = match eg with Some e -> pos e | None -> match List.rev el with (_,p) :: _ -> p | [] -> p1 in
+					None,punion p1 p2
+				| _ -> let p = punion p1 p2 in Some ((EBlock b,p)),p
 			in
-			parse_switch_cases eswitch ((el,eg,b) :: cases) s
+			parse_switch_cases eswitch ((el,eg,b,p) :: cases) s
 		)
 	| [< >] ->
 		List.rev cases , None

src/typing/matcher.ml

@@ -440,7 +440,7 @@ module Case = struct
 		case_pos : pos;
 	}
 
-	let make ctx t el eg eo with_type =
+	let make ctx t el eg eo_ast with_type p =
 		let rec collapse_case el = match el with
 			| e :: [] ->
 				e
@@ -467,7 +467,7 @@ module Case = struct
 			| None -> None
 			| Some e -> Some (type_expr ctx e Value)
 		in
-		let eo = match eo,with_type with
+		let eo = match eo_ast,with_type with
 			| None,WithType t ->
 				unify ctx ctx.t.tvoid t (pos e);
 				None
@@ -484,10 +484,15 @@ module Case = struct
 		ctx.ret <- old_ret;
 		List.iter (fun (v,t) -> v.v_type <- t) old_types;
 		save();
+		if ctx.is_display_file && Display.is_display_position p then begin match eo,eo_ast with
+			| Some e,Some e_ast -> ignore(Typer.display_expr ctx e_ast e false with_type p)
+			| None,None -> ignore(Typer.display_expr ctx (EBlock [],p) (mk (TBlock []) ctx.t.tvoid p) false with_type p)
+			| _ -> assert false
+		end;
 		{
 			case_guard = eg;
 			case_expr = eo;
-			case_pos = pos e;
+			case_pos = p;
 		},[],pat
 end
 
@@ -746,7 +751,7 @@ module Useless = struct
 	let check_case com p (case,bindings,patterns) =
 		let p = List.map (fun (_,_,patterns) -> patterns) p in
 		match u' p (copy p) (copy p) patterns [] [] with
-			| False -> com.warning "This pattern is unused" case.case_pos
+			| False -> com.warning "This case is unused" case.case_pos
 			| Pos p -> com.warning "This pattern is unused" p
 			| True -> ()
 
@@ -1368,7 +1373,6 @@ module Match = struct
 	open Typecore
 
 	let match_expr ctx e cases def with_type p =
-		(* if p.pfile <> "src/Main.hx" then raise Exit; *)
 		let match_debug = Meta.has (Meta.Custom ":matchDebug") ctx.curfield.cf_meta in
 		let rec loop e = match fst e with
 			| EArrayDecl el when (match el with [(EFor _ | EWhile _),_] -> false | _ -> true) ->
@@ -1385,19 +1389,19 @@ module Match = struct
 		let subjects = List.rev subjects in
 		let cases = match def with
 			| None -> cases
-			| Some eo -> cases @ [[EConst (Ident "_"),(match eo with None -> p | Some e -> pos e)],None,eo]
+			| Some (eo,p) -> cases @ [[EConst (Ident "_"),p],None,eo,p]
 		in
 		let tmono,with_type = match with_type with
 			| WithType t -> (match follow t with TMono _ -> Some t,Value | _ -> None,with_type)
 			| _ -> None,with_type
 		in
-		let cases = List.map (fun (el,eg,eo) ->
-			let case,bindings,pat = Case.make ctx t el eg eo with_type in
+		let cases = List.map (fun (el,eg,eo,p) ->
+			let case,bindings,pat = Case.make ctx t el eg eo with_type p in
 			case,bindings,[pat]
 		) cases in
 		let infer_switch_type () =
 			match with_type with
-				| NoValue -> mk_mono()
+				| NoValue -> ctx.t.tvoid
 				| Value ->
 					let el = List.map (fun (case,_,_) -> match case.Case.case_expr with Some e -> e | None -> mk (TBlock []) ctx.t.tvoid p) cases in
 					unify_min ctx el
@@ -1428,7 +1432,7 @@ module Match = struct
 			print_endline (s_expr_pretty e);
 			print_endline "TEXPR END";
 		end;
-		e
+		{e with epos = p}
 end
 ;;
 Typecore.match_expr_ref := Match.match_expr

src/typing/type.ml

@@ -2534,9 +2534,9 @@ module TExprToExpr = struct
 		| TWhile (e1,e2,flag) -> EWhile (convert_expr e1, convert_expr e2, flag)
 		| TSwitch (e,cases,def) ->
 			let cases = List.map (fun (vl,e) ->
-				List.map convert_expr vl,None,(match e.eexpr with TBlock [] -> None | _ -> Some (convert_expr e))
+				List.map convert_expr vl,None,(match e.eexpr with TBlock [] -> None | _ -> Some (convert_expr e)),e.epos
 			) cases in
-			let def = match eopt def with None -> None | Some (EBlock [],_) -> Some None | e -> Some e in
+			let def = match eopt def with None -> None | Some (EBlock [],_) -> Some (None,null_pos) | Some e -> Some (Some e,pos e) in
 			ESwitch (convert_expr e,cases,def)
 		| TEnumParameter _ ->
 			(* these are considered complex, so the AST is handled in TMeta(Meta.Ast) *)

src/typing/typecore.ml

@@ -148,7 +148,7 @@ let make_call_ref : (typer -> texpr -> texpr list -> t -> pos -> texpr) ref = re
 let type_expr_ref : (typer -> Ast.expr -> with_type -> texpr) ref = ref (fun _ _ _ -> assert false)
 let type_module_type_ref : (typer -> module_type -> t list option -> pos -> texpr) ref = ref (fun _ _ _ _ -> assert false)
 let unify_min_ref : (typer -> texpr list -> t) ref = ref (fun _ _ -> assert false)
-let match_expr_ref : (typer -> Ast.expr -> (Ast.expr list * Ast.expr option * Ast.expr option) list -> Ast.expr option option -> with_type -> Ast.pos -> texpr) ref = ref (fun _ _ _ _ _ _ -> assert false)
+let match_expr_ref : (typer -> Ast.expr -> (Ast.expr list * Ast.expr option * Ast.expr option * pos) list -> (Ast.expr option * pos) option -> with_type -> Ast.pos -> texpr) ref = ref (fun _ _ _ _ _ _ -> assert false)
 let get_pattern_locals_ref : (typer -> Ast.expr -> Type.t -> (string, tvar * pos) PMap.t) ref = ref (fun _ _ _ -> assert false)
 let get_constructor_ref : (typer -> tclass -> t list -> Ast.pos -> (t * tclass_field)) ref = ref (fun _ _ _ _ -> assert false)
 let cast_or_unify_ref : (typer -> t -> texpr -> Ast.pos -> texpr) ref = ref (fun _ _ _ _ -> assert false)

src/typing/typer.ml

@@ -2467,46 +2467,6 @@ and type_unop ctx op flag e p =
 	in
 	loop acc
 
-and type_switch_old ctx e cases def with_type p =
-	let eval = type_expr ctx e Value in
-	let el = ref [] in
-	let type_case_code e =
-		let e = (match e with
-			| Some e -> type_expr ctx e with_type
-			| None -> mk (TBlock []) ctx.com.basic.tvoid Ast.null_pos
-		) in
-		el := e :: !el;
-		e
-	in
-	let consts = Hashtbl.create 0 in
-	let exprs (el,_,e) =
-		let el = List.map (fun e ->
-			match type_expr ctx e (WithType eval.etype) with
-			| { eexpr = TConst c } as e ->
-				if Hashtbl.mem consts c then error "Duplicate constant in switch" e.epos;
-				Hashtbl.add consts c true;
-				e
-			| e ->
-				e
-		) el in
-		let locals = save_locals ctx in
-		let e = type_case_code e in
-		locals();
-		el, e
-	in
-	let cases = List.map exprs cases in
-	let def() = (match def with
-		| None -> None
-		| Some e ->
-			let locals = save_locals ctx in
-			let e = type_case_code e in
-			locals();
-			Some e
-	) in
-	let def = def() in
-	let t = if with_type = NoValue then (mk_mono()) else unify_min ctx (List.rev !el) in
-	mk (TSwitch (eval,cases,def)) t p
-
 and type_ident ctx i p mode =
 	try
 		type_ident_raise ctx i p mode
@@ -3556,13 +3516,9 @@ and type_expr ctx (e,p) (with_type:with_type) =
 		let cond = Codegen.AbstractCast.cast_or_unify ctx ctx.t.tbool cond cond.epos in
 		mk (TWhile (cond,e,DoWhile)) ctx.t.tvoid p
 	| ESwitch (e1,cases,def) ->
-		begin try
-			let wrap e1 = mk (TMeta((Meta.Ast,[e,p],p),e1)) e1.etype e1.epos in
-			let e = match_expr ctx e1 cases def with_type p in
-			wrap e
-		with Exit ->
-			type_switch_old ctx e1 cases def with_type p
-		end
+		let wrap e1 = mk (TMeta((Meta.Ast,[e,p],p),e1)) e1.etype e1.epos in
+		let e = match_expr ctx e1 cases def with_type p in
+		wrap e
 	| EReturn e ->
 		begin match e with
 			| None ->
@@ -4111,7 +4067,7 @@ and type_call ctx e el (with_type:with_type) p =
 		let et = type_expr ctx e Value in
 		(match follow et.etype with
 			| TEnum _ ->
-				let e = match_expr ctx e [[epat],None,Some (EConst(Ident "true"),p)] (Some (Some (EConst(Ident "false"),p))) (WithType ctx.t.tbool) p in
+				let e = match_expr ctx e [[epat],None,Some (EConst(Ident "true"),p),p] (Some (Some (EConst(Ident "false"),p),p)) (WithType ctx.t.tbool) p in
 				(* TODO: add that back *)
 (* 				let locals = !get_pattern_locals_ref ctx epat t in
 				PMap.iter (fun _ (_,p) -> display_error ctx "Capture variables are not allowed" p) locals; *)

tests/misc/projects/Issue2508/compile.hxml.stderr

@@ -1,10 +1,10 @@
-Main.hx:15: characters 8-13 : Warning : This pattern is unused
-Main.hx:20: characters 8-12 : Warning : This pattern is unused
-Main.hx:21: characters 8-13 : Warning : This pattern is unused
+Main.hx:15: characters 3-13 : Warning : This case is unused
+Main.hx:20: characters 3-12 : Warning : This case is unused
+Main.hx:21: characters 3-13 : Warning : This case is unused
 Main.hx:26: characters 5-10 : Warning : This pattern is unused
 Main.hx:32: characters 6-17 : Warning : This pattern is unused
-Main.hx:44: characters 8-30 : Warning : This pattern is unused
-Main.hx:50: characters 8-17 : Warning : This pattern is unused
-Main.hx:55: characters 8-13 : Warning : This pattern is unused
-Main.hx:60: characters 8-14 : Warning : This pattern is unused
+Main.hx:44: characters 3-30 : Warning : This case is unused
+Main.hx:50: characters 3-17 : Warning : This case is unused
+Main.hx:55: characters 3-13 : Warning : This case is unused
+Main.hx:60: characters 3-14 : Warning : This case is unused
 Main.hx:66: characters 8-14 : Warning : This pattern is unused

tests/misc/projects/Issue4247/compile-fail.hxml.stderr

@@ -1 +1 @@
-Main.hx:8: characters 8-10 : Incompatible pattern
+Main.hx:8: characters 3-21 : Incompatible pattern