+31 -27

src/loader/loader.ml

··· 1 1 + module Error = Model.Error 2 2 + 3 3 + 4 4 + 1 5 let read_string parent_definition location text = 2 2 - Model.Error.catch (fun () -> 6 6 + Error.catch (fun () -> 3 7 Attrs.read_string parent_definition location text) 4 8 5 9 6 10 7 7 - let corrupted : string -> (_, Model.Error.t) result = fun file -> 8 8 - Error (`With_filename_only {file; error = "corrupted"}) 11 11 + let corrupted : string -> Error.t = 12 12 + Error.filename_only "corrupted" 9 13 10 10 - let not_a_typedtree : string -> (_, Model.Error.t) result = fun file -> 11 11 - Error (`With_filename_only {file; error = "not a Typedtree"}) 14 14 + let not_a_typedtree : string -> Error.t = 15 15 + Error.filename_only "not a Typedtree" 12 16 13 13 - let not_an_implementation : string -> (_, Model.Error.t) result = fun file -> 14 14 - Error (`With_filename_only {file; error = "not an implementation"}) 17 17 + let not_an_implementation : string -> Error.t = 18 18 + Error.filename_only "not an implementation" 15 19 16 16 - let not_an_interface : string -> (_, Model.Error.t) result = fun file -> 17 17 - Error (`With_filename_only {file; error = "not an interface"}) 20 20 + let not_an_interface : string -> Error.t = 21 21 + Error.filename_only "not an interface" 18 22 19 19 - let wrong_version : string -> (_, Model.Error.t) result = fun file -> 20 20 - Error (`With_filename_only {file; error = "wrong OCaml version"}) 23 23 + let wrong_version : string -> Error.t = 24 24 + Error.filename_only "wrong OCaml version" 21 25 22 26 23 27 24 28 let read_cmti ~make_root ~filename = 25 29 match Cmt_format.read_cmt filename with 26 30 | exception Cmi_format.Error (Not_an_interface _) -> 27 27 - not_an_interface filename 31 31 + Error (not_an_interface filename) 28 32 | exception Cmt_format.Error (Not_a_typedtree _) -> 29 29 - not_a_typedtree filename 33 33 + Error (not_a_typedtree filename) 30 34 | cmt_info -> 31 35 match cmt_info.cmt_annots with 32 36 | Interface intf -> 33 37 begin match cmt_info.cmt_interface_digest with 34 34 - | None -> corrupted filename 38 38 + | None -> Error (corrupted filename) 35 39 | Some digest -> 36 36 - Model.Error.catch begin fun () -> 40 40 + Error.catch begin fun () -> 37 41 let name = cmt_info.cmt_modname in 38 42 let root = make_root ~module_name:name ~digest in 39 43 let (id, doc, items) = Cmti.read_interface root name intf in ··· 59 63 interface; hidden; content; expansion = None} 60 64 end 61 65 end 62 62 - | _ -> not_an_interface filename 66 66 + | _ -> Error (not_an_interface filename) 63 67 64 68 let read_cmt ~make_root ~filename = 65 69 match Cmt_format.read_cmt filename with 66 70 | exception Cmi_format.Error (Not_an_interface _) -> 67 67 - not_an_implementation filename 71 71 + Error (not_an_implementation filename) 68 72 | exception Cmi_format.Error (Wrong_version_interface _) -> 69 69 - wrong_version filename 73 73 + Error (wrong_version filename) 70 74 | exception Cmi_format.Error (Corrupted_interface _) -> 71 71 - corrupted filename 75 75 + Error (corrupted filename) 72 76 | exception Cmt_format.Error (Not_a_typedtree _) -> 73 73 - not_a_typedtree filename 77 77 + Error (not_a_typedtree filename) 74 78 | cmt_info -> 75 79 match cmt_info.cmt_annots with 76 80 | Packed(_, files) -> ··· 114 118 source; interface; hidden; content; expansion = None} 115 119 116 120 | Implementation impl -> 117 117 - Model.Error.catch begin fun () -> 121 121 + Error.catch begin fun () -> 118 122 let name = cmt_info.cmt_modname in 119 123 let interface, digest = 120 124 match cmt_info.cmt_interface_digest with ··· 146 150 source; interface; hidden; content; expansion = None} 147 151 end 148 152 149 149 - | _ -> not_an_implementation filename 153 153 + | _ -> Error (not_an_implementation filename) 150 154 151 155 let read_cmi ~make_root ~filename = 152 156 match Cmi_format.read_cmi filename with 153 157 | exception Cmi_format.Error (Not_an_interface _) -> 154 154 - not_an_interface filename 158 158 + Error (not_an_interface filename) 155 159 | exception Cmi_format.Error (Wrong_version_interface _) -> 156 156 - wrong_version filename 160 160 + Error (wrong_version filename) 157 161 | exception Cmi_format.Error (Corrupted_interface _) -> 158 158 - corrupted filename 162 162 + Error (corrupted filename) 159 163 | cmi_info -> 160 164 match cmi_info.cmi_crcs with 161 165 | (name, Some digest) :: imports when name = cmi_info.cmi_name -> 162 162 - Model.Error.catch begin fun () -> 166 166 + Error.catch begin fun () -> 163 167 let root = make_root ~module_name:name ~digest:digest in 164 168 let (id, doc, items) = Cmi.read_interface root name cmi_info.cmi_sign in 165 169 let imports = ··· 174 178 source; interface; hidden; content; expansion = None} 175 179 end 176 180 177 177 - | _ -> corrupted filename 181 181 + | _ -> Error (corrupted filename)

+11 -8

src/model/error.ml

··· 1 1 type full_location_payload = { 2 2 location : Location_.span; 3 3 - error : string; 3 3 + message : string; 4 4 } 5 5 6 6 type filename_only_payload = { 7 7 file : string; 8 8 - error : string; 8 8 + message : string; 9 9 } 10 10 11 11 type t = [ ··· 19 19 } 20 20 21 21 let make : string -> Location_.span -> t = fun message location -> 22 22 - `With_full_location {location; error = message} 22 22 + `With_full_location {location; message} 23 23 24 24 - let makef = fun format -> 24 24 + let filename_only : string -> string -> t = fun message file -> 25 25 + `With_filename_only {file; message} 26 26 + 27 27 + let format = fun format -> 25 28 (Printf.ksprintf make) format 26 29 27 30 let to_string : t -> string = function 28 28 - | `With_full_location {location; error} -> 31 31 + | `With_full_location {location; message} -> 29 32 let location_string = 30 33 if location.start.line = location.end_.line then 31 34 Printf.sprintf "line %i, characters %i-%i" ··· 39 42 location.end_.line 40 43 location.end_.column 41 44 in 42 42 - Printf.sprintf "File \"%s\", %s:\n%s" location.file location_string error 45 45 + Printf.sprintf "File \"%s\", %s:\n%s" location.file location_string message 43 46 44 44 - | `With_filename_only {file; error} -> 45 45 - Printf.sprintf "File \"%s\":\n%s" file error 47 47 + | `With_filename_only {file; message} -> 48 48 + Printf.sprintf "File \"%s\":\n%s" file message 46 49 47 50 exception Conveyed_by_exception of t 48 51

+12 -6

src/parser/parse_error.ml

··· 4 4 5 5 6 6 let bad_markup : string -> Location.span -> Error.t = 7 7 - Error.makef "'%s': bad markup" 7 7 + Error.format "'%s': bad markup" 8 8 9 9 let bad_section_level : string -> Location.span -> Error.t = 10 10 - Error.makef "'%s': bad section level (2-4 allowed)" 10 10 + Error.format "'%s': bad section level (2-4 allowed)" 11 11 12 12 let cannot_be_empty : what:string -> Location.span -> Error.t = fun ~what -> 13 13 - Error.makef "%s cannot be empty" what 13 13 + Error.format "%s cannot be empty" what 14 14 15 15 let must_begin_on_its_own_line : what:string -> Location.span -> Error.t = 16 16 fun ~what -> 17 17 - Error.makef "%s must begin on its own line" what 17 17 + Error.format "%s must begin on its own line" what 18 18 19 19 let must_be_followed_by_whitespace : what:string -> Location.span -> Error.t = 20 20 fun ~what -> 21 21 - Error.makef "%s must be followed by space, a tab, or a new line" what 21 21 + Error.format "%s must be followed by space, a tab, or a new line" what 22 22 23 23 let not_allowed 24 24 : ?suggestion:string -> what:string -> in_what:string -> Location.span -> ··· 38 38 let no_trailing_whitespace_in_verbatim : Location.span -> Error.t = 39 39 Error.make "'v}' must be preceded by whitespace" 40 40 41 41 + let only_one_title_allowed : Location.span -> Error.t = 42 42 + Error.make "only one title-level heading is allowed" 43 43 + 44 44 + let sections_not_allowed : Location.span -> Error.t = 45 45 + Error.make "sections not allowed in this comment" 46 46 + 41 47 let stray_at : Location.span -> Error.t = 42 48 Error.make "stray '@'" 43 49 ··· 57 63 Error.make "'@see' must be followed by <url>, 'file', or \"document title\"" 58 64 59 65 let unknown_tag : string -> Location.span -> Error.t = 60 60 - Error.makef "unknown tag '%s'" 66 66 + Error.format "unknown tag '%s'" 61 67 62 68 let unpaired_right_brace : Location.span -> Error.t = 63 69 Error.make "unpaired '}' (end of markup)"

+5 -24

src/parser/semantics.ml

··· 34 34 35 35 match status.sections_allowed, level with 36 36 | `None, _ -> 37 37 - let message : Error.t = 38 38 - `With_full_location { 39 39 - location; 40 40 - error = "sections not allowed in this comment"; 41 41 - } 42 42 - in 43 43 - warning status message; 37 37 + warning status (Parse_error.sections_not_allowed location); 44 38 let element = 45 39 Location.at location 46 40 (`Paragraph [Location.at location ··· 49 43 parsed_a_title, element 50 44 51 45 | `All, 1 -> 52 52 - if parsed_a_title then begin 53 53 - let message : Error.t = 54 54 - `With_full_location { 55 55 - location = location; 56 56 - error = "only one title-level heading is allowed"; 57 57 - } 58 58 - in 59 59 - Error.raise_exception message 60 60 - end; 46 46 + if parsed_a_title then 47 47 + Error.raise_exception (Parse_error.only_one_title_allowed location); 61 48 let element = `Heading (`Title, label, content) in 62 49 let element = Location.at location element in 63 50 true, element ··· 69 56 | 3 -> `Subsection 70 57 | 4 -> `Subsubsection 71 58 | _ -> 72 72 - let message : Error.t = 73 73 - `With_full_location { 74 74 - location = location; 75 75 - error = 76 76 - Printf.sprintf "'%i': bad section level (2-4 allowed)" level; 77 77 - } 78 78 - in 79 79 - warning status message; 59 59 + Parse_error.bad_section_level (string_of_int level) location 60 60 + |> warning status; 80 61 if level < 2 then 81 62 `Section 82 63 else