shieldtail/errors.ml at master · dansusman/shieldtail · GitHub

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
75
76
77
open Printf
open Exprs
open Pretty

exception ParseError of string (* parse-error message *)

exception UnboundId of string * sourcespan (* name, where used *)

exception UnboundFun of string * sourcespan (* name of fun, where used *)

exception ShadowId of string * sourcespan * sourcespan (* name, where used, where defined *)

exception DuplicateId of string * sourcespan * sourcespan (* name, where used, where defined *)

exception DuplicateFun of string * sourcespan * sourcespan (* name, where used, where defined *)

exception Overflow of int64 * sourcespan (* value, where used *)

exception Arity of int * int * sourcespan (* intended arity, actual arity, where called *)

exception NotYetImplemented of string (* TODO: Message to show *)

exception Unsupported of string * sourcespan

exception InternalCompilerError of string (* Major failure: message to show *)

exception LetRecNonFunction of sourcespan bind * sourcespan (* name binding, where defined *)

exception ShouldBeFunction of string * sourcespan (* name, where defined, actual typ *)

exception
  InvalidASCIICode of int * sourcespan (* the invalid ascii code given, and its string's location *)

exception
  DeclArity of string * int * int * sourcespan (* name, num args, num types, where defined *)

(* Stringifies a list of compilation errors *)
let print_errors (exns : exn list) : string list =
  List.map
    (fun e ->
      match e with
      | ParseError msg -> msg
      | NotYetImplemented msg -> "Not yet implemented: " ^ msg
      | Unsupported (msg, loc) -> sprintf "Unsupported: %s at <%s>" msg (string_of_sourcespan loc)
      | InternalCompilerError msg -> "Internal Compiler Error: " ^ msg
      | UnboundId (x, loc) ->
          sprintf "The identifier %s, used at <%s>, is not in scope" x (string_of_sourcespan loc)
      | UnboundFun (x, loc) ->
          sprintf "The function name %s, used at <%s>, is not in scope" x (string_of_sourcespan loc)
      | ShadowId (x, loc, existing) ->
          sprintf "The identifier %s, defined at <%s>, shadows one defined at <%s>" x
            (string_of_sourcespan loc) (string_of_sourcespan existing)
      | DuplicateId (x, loc, existing) ->
          sprintf "The identifier %s, redefined at <%s>, duplicates one at <%s>" x
            (string_of_sourcespan loc) (string_of_sourcespan existing)
      | DuplicateFun (x, loc, existing) ->
          sprintf "The function name %s, redefined at <%s>, duplicates one at <%s>" x
            (string_of_sourcespan loc) (string_of_sourcespan existing)
      | Overflow (num, loc) ->
          sprintf "The number literal %Ld, used at <%s>, is not supported in this language" num
            (string_of_sourcespan loc)
      | Arity (expected, actual, loc) ->
          sprintf "The function called at <%s> expected an arity of %d, but received %d arguments"
            (string_of_sourcespan loc) expected actual
      | DeclArity (name, num_args, num_types, loc) ->
          sprintf "The function %s, defined at %s, has %d arguments but only %d types provided" name
            (string_of_sourcespan loc) num_args num_types
      | ShouldBeFunction (name, loc) ->
          sprintf "The function %s, at %s, should be function" name (string_of_sourcespan loc)
      | LetRecNonFunction (bind, loc) ->
          sprintf "Binding error at %s: Let-rec expected a name binding to a lambda; got %s"
            (string_of_sourcespan loc) (string_of_bind bind)
      | InvalidASCIICode (code, loc) ->
          sprintf "Invalid ASCII code %d found at <%s>" code (string_of_sourcespan loc)
      | _ -> sprintf "%s" (Printexc.to_string e) )
    exns
;;