From 1e19fc969ed553934d51b565d5d9ad010cf3b569 Mon Sep 17 00:00:00 2001 From: Patrick Walton Date: Wed, 13 Oct 2010 15:34:18 -0700 Subject: [PATCH] Use "friendly" types throughout the typechecker --- src/boot/me/type.ml | 78 +++++++++++++++++++++++---------------------- 1 file changed, 40 insertions(+), 38 deletions(-) diff --git a/src/boot/me/type.ml b/src/boot/me/type.ml index 4427890411c..e93c8fc42c1 100644 --- a/src/boot/me/type.ml +++ b/src/boot/me/type.ml @@ -244,6 +244,8 @@ let type_error expected actual = (* We explicitly curry [cx] like this to avoid threading it through all the * inner functions. *) let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) = + let friendly_string_of_ty = friendly_stringify cx (Ast.sprintf_ty ()) in + (* Returns the part of the type that matters for typechecking. *) let rec fundamental_ty (ty:Ast.ty) : Ast.ty = match ty with @@ -253,7 +255,7 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) = let sprintf_ltype _ (lty:ltype) : string = match lty with - LTYPE_mono ty | LTYPE_poly (_, ty) -> Ast.sprintf_ty () ty + LTYPE_mono ty | LTYPE_poly (_, ty) -> friendly_string_of_ty ty | LTYPE_module items -> Ast.sprintf_mod_items () items in @@ -529,23 +531,23 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) = let base_ity = match internal_check_lval TYPAT_wild base with LTYPE_poly (_, ty) -> - Common.err None "can't index the polymorphic type '%a'" - Ast.sprintf_ty ty + Common.err None "can't index the polymorphic type '%s'" + (friendly_string_of_ty ty) | LTYPE_mono ty -> `Type (fundamental_ty ty) | LTYPE_module items -> `Module items in - let sprintf_itype chan () = + let string_of_itype () = match base_ity with - `Type ty -> Ast.sprintf_ty chan ty - | `Module items -> Ast.sprintf_mod_items chan items + `Type ty -> friendly_string_of_ty ty + | `Module items -> Ast.sprintf_mod_items () items in let _ = iflog cx (fun _ -> - log cx "base lval %a, base type %a" - Ast.sprintf_lval base sprintf_itype ()) + log cx "base lval %a, base type %s" + Ast.sprintf_lval base (string_of_itype ())) in let rec typecheck base_ity = @@ -558,15 +560,15 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) = | None -> Common.err None - "field '%s' is not one of the fields of '%a'" + "field '%s' is not one of the fields of '%s'" id - sprintf_itype () + (string_of_itype ()) in LTYPE_mono comp_ty | `Type (Ast.TY_rec _), _ -> - Common.err None "the record type '%a' must be indexed by name" - sprintf_itype () + Common.err None "the record type '%s' must be indexed by name" + (string_of_itype ()) | `Type (Ast.TY_obj ty_obj), Ast.COMP_named (Ast.COMP_ident id) -> let comp_ty = @@ -575,17 +577,17 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) = with Not_found -> Common.err None - "method '%s' is not one of the methods of '%a'" + "method '%s' is not one of the methods of '%s'" id - sprintf_itype () + (string_of_itype ()) in LTYPE_mono comp_ty | `Type (Ast.TY_obj _), _ -> Common.err None - "the object type '%a' must be indexed by name" - sprintf_itype () + "the object type '%s' must be indexed by name" + (string_of_itype ()) | `Type (Ast.TY_tup ty_tup), Ast.COMP_named (Ast.COMP_idx idx) when idx < Array.length ty_tup -> @@ -594,15 +596,15 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) = | `Type (Ast.TY_tup _), Ast.COMP_named (Ast.COMP_idx idx) -> Common.err None - "member '_%d' is not one of the members of '%a'" + "member '_%d' is not one of the members of '%s'" idx - sprintf_itype () + (string_of_itype ()) | `Type (Ast.TY_tup _), _ -> Common.err None - "the tuple type '%a' must be indexed by tuple index" - sprintf_itype () + "the tuple type '%s' must be indexed by tuple index" + (string_of_itype ()) | `Type (Ast.TY_vec ty_vec), Ast.COMP_atom atom -> demand_integer (check_atom atom); @@ -610,8 +612,8 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) = | `Type (Ast.TY_vec _), _ -> Common.err None - "the vector type '%a' must be indexed by an integral type" - sprintf_itype () + "the vector type '%s' must be indexed by an integral type" + (string_of_itype ()) | `Type Ast.TY_str, Ast.COMP_atom atom -> demand_integer (check_atom atom); @@ -626,15 +628,15 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) = typecheck (`Type ty_box) (* automatically dereference! *) | `Type ty, Ast.COMP_named (Ast.COMP_ident _) -> - Common.err None "the type '%a' can't be indexed by name" - Ast.sprintf_ty ty + Common.err None "the type '%s' can't be indexed by name" + (friendly_string_of_ty ty) | `Type ty, Ast.COMP_named (Ast.COMP_app _) -> Common.err None - "the type '%a' has no type parameters, so it can't be applied \ + "the type '%s' has no type parameters, so it can't be applied \ to types" - Ast.sprintf_ty ty + (friendly_string_of_ty ty) | `Module items, Ast.COMP_named ((Ast.COMP_ident id) as name_comp) | `Module items, Ast.COMP_named ((Ast.COMP_app (id, _)) @@ -666,21 +668,21 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) = | _, Ast.COMP_named (Ast.COMP_idx _) -> Common.err None - "%a isn't a tuple, so it can't be indexed by tuple index" - sprintf_itype () + "%s isn't a tuple, so it can't be indexed by tuple index" + (string_of_itype ()) | _, Ast.COMP_atom atom -> Common.err None - "%a can't by indexed by the type '%a'" - sprintf_itype () - Ast.sprintf_ty (check_atom atom) + "%s can't by indexed by the type '%s'" + (string_of_itype ()) + (friendly_string_of_ty (check_atom atom)) | _, Ast.COMP_deref -> Common.err None - "%a isn't a box and can't be dereferenced" - sprintf_itype () + "%s isn't a box and can't be dereferenced" + (string_of_itype ()) in typecheck base_ity @@ -749,10 +751,10 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) = | TYPAT_ty expected, (LTYPE_poly _ as lty) -> Common.err None - "not enough context to automatically instantiate '%a' to '%a'; \ + "not enough context to automatically instantiate '%a' to '%s'; \ please supply type parameters explicitly" sprintf_ltype lty - Ast.sprintf_ty expected + (friendly_string_of_ty expected) | _, LTYPE_module _ -> Common.err None "can't refer to a module as a first-class value" @@ -1033,9 +1035,9 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) = then () else Common.err None - "mismatched types in vec-append: %a += %a" - Ast.sprintf_ty dst_ty - Ast.sprintf_ty src_ty + "mismatched types in vec-append: %s += %s" + (friendly_string_of_ty dst_ty) + (friendly_string_of_ty src_ty) | Ast.TY_str, (Ast.TY_mach Common.TY_u8) | Ast.TY_str, Ast.TY_str -> () | _ ->