From 9a539a5dd18d3e8cf9dfab59f793d2e4df58464c Mon Sep 17 00:00:00 2001 From: Patrick Walton Date: Wed, 20 Oct 2010 17:57:11 -0700 Subject: [PATCH] Move the "friendly" type printer to semant --- src/boot/me/semant.ml | 72 ++++++++++++++++++++++++++++++ src/boot/me/type.ml | 100 ++++++------------------------------------ 2 files changed, 85 insertions(+), 87 deletions(-) diff --git a/src/boot/me/semant.ml b/src/boot/me/semant.ml index efa64c9ce53..f6be30afc1d 100644 --- a/src/boot/me/semant.ml +++ b/src/boot/me/semant.ml @@ -2679,6 +2679,78 @@ let glue_str (cx:ctxt) (g:glue) : string = | GLUE_vec_grow -> "glue$vec_grow" ;; +let rec pretty_ty_str (cx:ctxt) (fallback:(Ast.ty -> string)) (ty:Ast.ty) = + let cache = cx.ctxt_user_type_names in + if Hashtbl.mem cache ty then + let names = List.map (Ast.sprintf_name ()) (Hashtbl.find_all cache ty) in + String.concat " = " names + else + match ty with + Ast.TY_vec ty' -> "vec[" ^ (pretty_ty_str cx fallback ty') ^ "]" + | Ast.TY_chan ty' -> + "chan[" ^ (pretty_ty_str cx fallback ty') ^ "]" + | Ast.TY_port ty' -> + "port[" ^ (pretty_ty_str cx fallback ty') ^ "]" + | Ast.TY_box ty' -> "@" ^ (pretty_ty_str cx fallback ty') + | Ast.TY_mutable ty' -> + "(mutable " ^ (pretty_ty_str cx fallback ty') ^ ")" + | Ast.TY_constrained (ty', _) -> + "(" ^ (pretty_ty_str cx fallback ty') ^ " : )" + | Ast.TY_tup tys -> + let tys_str = Array.map (pretty_ty_str cx fallback) tys in + "tup(" ^ (String.concat ", " (Array.to_list tys_str)) ^ ")" + | Ast.TY_rec fields -> + let format_field (ident, ty') = + ident ^ "=" ^ (pretty_ty_str cx fallback ty') + in + let fields = Array.to_list (Array.map format_field fields) in + "rec(" ^ (String.concat ", " fields) ^ ")" + | Ast.TY_fn (fnsig, _) -> + let format_slot slot = + match slot.Ast.slot_ty with + None -> Common.bug () "no ty in slot" + | Some ty' -> pretty_ty_str cx fallback ty' + in + let fn_args = Array.map format_slot fnsig.Ast.sig_input_slots in + let fn_args_str = String.concat ", " (Array.to_list fn_args) in + let fn_rv_str = format_slot fnsig.Ast.sig_output_slot in + Printf.sprintf "fn(%s) -> %s" fn_args_str fn_rv_str + | Ast.TY_tag { Ast.tag_id = tag_id; Ast.tag_args = args } -> + let tag_info = Hashtbl.find cx.ctxt_all_tag_info tag_id in + let tag_idents = tag_info.tag_idents in + let item_id = ref None in + (* Ugly hack ahead... *) + begin + try + Hashtbl.iter + begin + fun _ (_, item_id', _) -> + item_id := Some item_id'; raise Exit + end + tag_idents + with Exit -> (); + end; + begin + match !item_id with + None -> fallback ty + | Some item_id -> + let item_types = cx.ctxt_all_item_types in + let ty = Hashtbl.find item_types item_id in + let args_suffix = + if Array.length args == 0 then "" + else + Printf.sprintf "[%s]" + (String.concat "," + (Array.to_list + (Array.map + (pretty_ty_str cx fallback) + args))) + in + (pretty_ty_str cx fallback ty) ^ args_suffix + end + + | _ -> fallback ty (* TODO: we can do better for objects *) +;; (* * Local Variables: diff --git a/src/boot/me/type.ml b/src/boot/me/type.ml index 8056dc1ee7f..d22e0b051ce 100644 --- a/src/boot/me/type.ml +++ b/src/boot/me/type.ml @@ -37,80 +37,6 @@ let iflog cx thunk = else () ;; -(* Pretty-printing of type names *) - -let rec friendly_stringify cx fallback ty = - let cache = cx.Semant.ctxt_user_type_names in - if Hashtbl.mem cache ty then - let names = List.map (Ast.sprintf_name ()) (Hashtbl.find_all cache ty) in - String.concat " = " names - else - match ty with - Ast.TY_vec ty' -> "vec[" ^ (friendly_stringify cx fallback ty') ^ "]" - | Ast.TY_chan ty' -> - "chan[" ^ (friendly_stringify cx fallback ty') ^ "]" - | Ast.TY_port ty' -> - "port[" ^ (friendly_stringify cx fallback ty') ^ "]" - | Ast.TY_box ty' -> "@" ^ (friendly_stringify cx fallback ty') - | Ast.TY_mutable ty' -> - "(mutable " ^ (friendly_stringify cx fallback ty') ^ ")" - | Ast.TY_constrained (ty', _) -> - "(" ^ (friendly_stringify cx fallback ty') ^ " : )" - | Ast.TY_tup tys -> - let tys_str = Array.map (friendly_stringify cx fallback) tys in - "tup(" ^ (String.concat ", " (Array.to_list tys_str)) ^ ")" - | Ast.TY_rec fields -> - let format_field (ident, ty') = - ident ^ "=" ^ (friendly_stringify cx fallback ty') - in - let fields = Array.to_list (Array.map format_field fields) in - "rec(" ^ (String.concat ", " fields) ^ ")" - | Ast.TY_fn (fnsig, _) -> - let format_slot slot = - match slot.Ast.slot_ty with - None -> Common.bug () "no ty in slot" - | Some ty' -> friendly_stringify cx fallback ty' - in - let fn_args = Array.map format_slot fnsig.Ast.sig_input_slots in - let fn_args_str = String.concat ", " (Array.to_list fn_args) in - let fn_rv_str = format_slot fnsig.Ast.sig_output_slot in - Printf.sprintf "fn(%s) -> %s" fn_args_str fn_rv_str - | Ast.TY_tag { Ast.tag_id = tag_id; Ast.tag_args = args } -> - let tag_info = Hashtbl.find cx.Semant.ctxt_all_tag_info tag_id in - let tag_idents = tag_info.Semant.tag_idents in - let item_id = ref None in - (* Ugly hack ahead... *) - begin - try - Hashtbl.iter - begin - fun _ (_, item_id', _) -> - item_id := Some item_id'; raise Exit - end - tag_idents - with Exit -> (); - end; - begin - match !item_id with - None -> fallback ty - | Some item_id -> - let item_types = cx.Semant.ctxt_all_item_types in - let ty = Hashtbl.find item_types item_id in - let args_suffix = - if Array.length args == 0 then "" - else - Printf.sprintf "[%s]" - (String.concat "," - (Array.to_list - (Array.map - (friendly_stringify cx fallback) - args))) - in - (friendly_stringify cx fallback ty) ^ args_suffix - end - - | _ -> fallback ty (* TODO: we can do better for objects *) - let head_only ty = match ty with @@ -220,7 +146,7 @@ and summarize_difference cx (expected:Ast.ty) (actual:Ast.ty) Printf.bprintf abuf "%s" a in - Buffer.add_string ebuf (friendly_stringify cx head_only expected); + Buffer.add_string ebuf (Semant.pretty_ty_str cx head_only expected); begin match expected, actual with @@ -246,7 +172,7 @@ and summarize_difference cx (expected:Ast.ty) (actual:Ast.ty) p "mutable "; sub e a; | (_, a) -> - Buffer.add_string abuf (friendly_stringify cx head_only a) + Buffer.add_string abuf (Semant.pretty_ty_str cx head_only a) end; (Buffer.contents ebuf, Buffer.contents abuf) end @@ -257,13 +183,13 @@ let type_error_full expected actual = ;; let type_error cx expected actual = - type_error_full expected (friendly_stringify cx head_only actual) + type_error_full expected (Semant.pretty_ty_str cx head_only 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 + let pretty_ty_str = Semant.pretty_ty_str cx (Ast.sprintf_ty ()) in (* Returns the part of the type that matters for typechecking. *) let rec fundamental_ty (ty:Ast.ty) : Ast.ty = @@ -274,7 +200,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) -> friendly_string_of_ty ty + LTYPE_mono ty | LTYPE_poly (_, ty) -> pretty_ty_str ty | LTYPE_module items -> Ast.sprintf_mod_items () items in @@ -553,14 +479,14 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) = match internal_check_lval TYPAT_wild base with LTYPE_poly (_, ty) -> Common.err None "can't index the polymorphic type '%s'" - (friendly_string_of_ty ty) + (pretty_ty_str ty) | LTYPE_mono ty -> `Type (fundamental_ty ty) | LTYPE_module items -> `Module items in let string_of_itype () = match base_ity with - `Type ty -> friendly_string_of_ty ty + `Type ty -> pretty_ty_str ty | `Module items -> Ast.sprintf_mod_items () items in @@ -650,14 +576,14 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) = | `Type ty, Ast.COMP_named (Ast.COMP_ident _) -> Common.err None "the type '%s' can't be indexed by name" - (friendly_string_of_ty ty) + (pretty_ty_str ty) | `Type ty, Ast.COMP_named (Ast.COMP_app _) -> Common.err None "the type '%s' has no type parameters, so it can't be applied \ to types" - (friendly_string_of_ty ty) + (pretty_ty_str ty) | `Module items, Ast.COMP_named ((Ast.COMP_ident id) as name_comp) | `Module items, Ast.COMP_named ((Ast.COMP_app (id, _)) @@ -697,7 +623,7 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) = None "%s can't by indexed by the type '%s'" (string_of_itype ()) - (friendly_string_of_ty (check_atom atom)) + (pretty_ty_str (check_atom atom)) | _, Ast.COMP_deref -> Common.err @@ -775,7 +701,7 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) = "not enough context to automatically instantiate '%a' to '%s'; \ please supply type parameters explicitly" sprintf_ltype lty - (friendly_string_of_ty expected) + (pretty_ty_str expected) | _, LTYPE_module _ -> Common.err None "can't refer to a module as a first-class value" @@ -1059,8 +985,8 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) = else Common.err None "mismatched types in vec-append: %s += %s" - (friendly_string_of_ty dst_ty) - (friendly_string_of_ty src_ty) + (pretty_ty_str dst_ty) + (pretty_ty_str src_ty) | Ast.TY_str, (Ast.TY_mach Common.TY_u8) | Ast.TY_str, Ast.TY_str -> () | _ -> -- GitLab