Source file errorMg.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
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
type location = Lexing.position * Lexing.position

let update_loc ?filename lexbuf =
  let pos = lexbuf.Lexing.lex_curr_p in
  let new_file = match filename with
    | None -> pos.Lexing.pos_fname
    | Some s -> s
  in
    lexbuf.Lexing.lex_curr_p <- { pos with
			     Lexing.pos_fname = new_file;
			     Lexing.pos_lnum = pos.Lexing.pos_lnum + 1;
			     Lexing.pos_bol = pos.Lexing.pos_cnum;
			 }

module type E =
  sig
    type t
    val to_string : t -> string
  end
  
module type ERROR =
  sig

    type bracket =
      | Round
      | Square
      | Curly

    type lex_error =
      | Unstarted_comment
      | Unstarted_bracket
      | Mismatch_parentheses of bracket
      | Unclosed_comment
      | Expect of string
      | Bad_token

    type synt_error
      
    type error =
      | SyntError of synt_error
      | LexError of lex_error
      | SysError of string

    (** The exception that should be raised when an error occur *)
    exception Error of (error * location)

    (** [error_msg e ~filename] returns a string describing the error
       [e] while the file [filename] is being processed *)
    val error_msg : ?filename:string -> (error * location) -> string

    val empty_bracket_stack : (bracket * location) list
    
    val push_bracket : bracket -> location -> (bracket * location) list -> (bracket * location) list

    val pop_bracket : bracket -> location -> (bracket * location) list -> (bracket * location) list
      
    val check_brackets : (bracket * location) list -> unit
      
  end
  


              
  
module Make(E:E) =
  struct

    type bracket =
      | Round
      | Square
      | Curly

    let kind_to_char = function
      | Round -> '('
      | Square -> '['
      | Curly -> '{'
      
    type lex_error =
      | Unstarted_comment
      | Unstarted_bracket
      | Mismatch_parentheses of bracket
      | Unclosed_comment
      | Expect of string
      | Bad_token

    let lex_error_to_string = function
      | Unstarted_comment -> "Syntax error: No comment opened before this closing of comment"
      | Unstarted_bracket -> "Syntax error: No bracket opened before this right bracket"
      | Unclosed_comment -> "Syntax error: Unclosed comment"
      | Mismatch_parentheses k -> Printf.sprintf "Syntax error: Unclosed parenthesis '%c'" (kind_to_char k)
      | Expect s -> Printf.sprintf "Syntax error: %s expected" s
      | Bad_token -> "Lexing error: no such token allowed"
                   



      
    type synt_error = E.t
      
    type error =
      | SyntError of synt_error
      | LexError of lex_error
      | SysError of string

                   
    exception Error of (error * location)

    let compute_comment_for_location (pos1,pos2) =
      let line2 = pos2.Lexing.pos_lnum in
      let col2 = pos2.Lexing.pos_cnum - pos2.Lexing.pos_bol in
      let pos1 = pos1 in
      let line1 = pos1.Lexing.pos_lnum in
      let col1 = pos1.Lexing.pos_cnum - pos1.Lexing.pos_bol in
      if line1=line2 then
        Printf.sprintf "line %d, characters %d-%d" line2 col1 col2
      else
        Printf.sprintf "line %d, character %d to line %d, character %d" line1 col1 line2 col2
      
            
    let error_msg ?filename (err,loc)  =
      let input =
        match filename with
        | None -> ""
        | Some f -> Printf.sprintf "File \"%s\"," f in
      let msg =
        match err with
        | LexError e -> lex_error_to_string e
        | SysError e -> e
        | SyntError e -> E.to_string e in
      Printf.sprintf
        "%s%s\n%s"
        input
        (compute_comment_for_location loc)
        msg

    
  let empty_bracket_stack = []

  let push_bracket br loc stack =
    (br,loc)::stack

  let pop_bracket br l stack=
    match stack with
    | [] -> raise (Error (LexError Unstarted_bracket, l))
    | (k,_)::tl when k = br -> tl
    | (k,l)::_ -> raise (Error (LexError (Mismatch_parentheses k),l))

  let check_brackets stack =
    match stack with
    | [] -> ()
    | (k,loc)::_ -> raise (Error (LexError (Mismatch_parentheses k),loc))

      
  end