Source file error.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
open Source

exception ParseError of region * string
exception UnparseError of string
exception RuntimeError of region * string
exception ElabError of region * string
exception AlgoError of region * string
exception StructError of region * string
exception ProseError of region * string
exception BuiltinError of region * string
exception InterpError of region * string
exception ExternError of region * string
exception StfError of string
exception SpliceError of region * string

let debug_errors = false

let string_of_error at msg =
  if at = no_region then msg else string_of_region at ^ ": " ^ msg

let warn (at : region) (category : string) (msg : string) =
  Printf.eprintf "%s\n%!" (string_of_error at (category ^ " warning: " ^ msg))

(* Parser errors *)

let error_parse (at : region) (msg : string) = raise (ParseError (at, msg))
let error_parse_no_region (msg : string) = raise (ParseError (no_region, msg))

(* Unparser errors *)

let error_unparse (msg : string) = raise (UnparseError msg)

(* Runtime errors *)

let error_runtime (at : region) (msg : string) = raise (RuntimeError (at, msg))
let warn_runtime (at : region) (msg : string) = warn at "runtime" msg

(* Elaboration errors *)

let error_elab (at : region) (msg : string) = raise (ElabError (at, msg))
let warn_elab (at : region) (msg : string) = warn at "elab" msg

(* Algo errors *)

let error_algo (at : region) (msg : string) = raise (AlgoError (at, msg))
let warn_algo (at : region) (msg : string) = warn at "algo" msg

(* Structuring errors *)

let error_struct (at : region) (msg : string) = raise (StructError (at, msg))
let warn_struct (at : region) (msg : string) = warn at "struct" msg

(* Prosification errors *)

let error_prose (at : region) (msg : string) = raise (ProseError (at, msg))
let warn_prose (at : region) (msg : string) = warn at "prose" msg

(* Builtin errors *)

let error_builtin (at : region) (msg : string) = raise (BuiltinError (at, msg))
let warn_builtin (at : region) (msg : string) = warn at "builtin" msg

(* Interpreter errors *)

let error_interp (at : region) (msg : string) = raise (InterpError (at, msg))
let warn_interp (at : region) (msg : string) = warn at "interp" msg
let error_extern (at : region) (msg : string) = raise (ExternError (at, msg))
let warn_extern (at : region) (msg : string) = warn at "extern" msg
let error_stf (msg : string) = raise (StfError msg)

(* Splicer errors *)

let error_splice (at : region) (msg : string) = raise (SpliceError (at, msg))
let warn_splice (at : region) (msg : string) = warn at "splice" msg