164 lines
4.3 KiB
OCaml
164 lines
4.3 KiB
OCaml
module Region = Simple_utils.Region
|
|
|
|
type macro = {
|
|
origin : Region.t; (* Not ghost *)
|
|
current : Region.t (* Maybe ghost *)
|
|
}
|
|
|
|
type location =
|
|
Loc of Region.t (* Not ghost *)
|
|
| Link of macro
|
|
|
|
(* Regions must not be ghosts and strings must not be empty. *)
|
|
|
|
type valid_lexeme = string Region.reg (* Not ghost, not empty. *)
|
|
type invalid_lexeme = string Region.reg (* Not ghost, empty if EOF. *)
|
|
|
|
type phase =
|
|
Lexer
|
|
| Parser of valid_lexeme option * invalid_lexeme
|
|
| Scoping
|
|
|
|
type error = <
|
|
location : location;
|
|
message : string; (* Sentence ending with a period *)
|
|
hint : string; (* Suggestion to solve the issue *)
|
|
help : string (* Off-program help *)
|
|
>
|
|
|
|
type invalid_error = Ghost_region
|
|
|
|
let check_loc = function
|
|
Loc reg ->
|
|
if reg#is_ghost then
|
|
Stdlib.Error Ghost_region
|
|
else Ok ()
|
|
| Link {origin; _} ->
|
|
if origin#is_ghost then
|
|
Stdlib.Error Ghost_region
|
|
else Ok ()
|
|
|
|
let make_error ~location ~message ~hint ~help =
|
|
match check_loc location with
|
|
Stdlib.Ok () ->
|
|
Ok (object
|
|
method location = location
|
|
method message = message
|
|
method hint = hint
|
|
method help = help
|
|
end)
|
|
| Error _ as e -> e
|
|
|
|
type warning = <
|
|
location : location;
|
|
message : string; (* Sentence ending with a period *)
|
|
hint : string; (* Idem *)
|
|
>
|
|
|
|
type invalid_warning = invalid_error
|
|
|
|
let make_warning ~location ~message ~hint =
|
|
match check_loc location with
|
|
Stdlib.Ok () ->
|
|
Ok (object
|
|
method location = location
|
|
method message = message
|
|
method hint = hint
|
|
method help = help
|
|
end)
|
|
| Error _ as e -> e
|
|
|
|
type kind =
|
|
Error of error (* Failure of an external invariant *)
|
|
| Internal of string (* Failure of an internal invariant *)
|
|
| External of string (* Failure of an external process *)
|
|
| Warning of warning
|
|
| Info of (unit -> string) (* Log *)
|
|
|
|
type entry = <
|
|
phase : phase;
|
|
kind : kind
|
|
>
|
|
|
|
type invalid_entry =
|
|
Ghost_lexeme
|
|
| Empty_lexeme
|
|
|
|
let check_phase = function
|
|
Parser (Some valid_lexeme, invalid_lexeme) ->
|
|
let open Region in
|
|
if valid_lexeme.region#is_ghost
|
|
|| invalid_lexeme.region#is_ghost
|
|
then Stdlib.Error Ghost_lexeme
|
|
else if valid_lexeme.value = ""
|
|
then Stdlib.Error Empty_lexeme
|
|
else Ok ()
|
|
| Parser (None, invalid_lexeme) ->
|
|
if invalid_lexeme.region#is_ghost
|
|
then Stdlib.Error Ghost_lexeme
|
|
else Ok ()
|
|
| Lexer
|
|
| Scoping -> Ok ()
|
|
|
|
let make_entry ~phase ~kind =
|
|
match check_phase phase with
|
|
Stdlib.Error _ as e -> e
|
|
| Ok () -> Ok (object
|
|
method phase = phase
|
|
method kind = kind
|
|
end)
|
|
|
|
type memo = <
|
|
mode : [`Byte | `Point]; (* Bytes vs UTF-8 *)
|
|
offsets : bool; (* [true] for horizontal offsets *)
|
|
log : entry FQueue.t
|
|
>
|
|
|
|
type t = memo
|
|
|
|
let empty_memo ~mode ~offsets : memo =
|
|
object
|
|
method mode = mode
|
|
method offsets = offsets
|
|
method log = FQueue.empty
|
|
method enqueue entry = {< log = FQueue.enq entry log >}
|
|
method dequeue =
|
|
match FQueue.deq log with
|
|
None -> None
|
|
| Some (log, entry) -> Some ({< log=log >}, entry)
|
|
end
|
|
|
|
let sprintf = Printf.sprintf
|
|
|
|
let string_of_entry ~(file:bool) entry : string =
|
|
let reg = entry#region#to_string
|
|
~file
|
|
~offsets:entry#offsets
|
|
error#mode in
|
|
let string =
|
|
match error#phase with
|
|
Parser (None, invalid_lexeme) ->
|
|
(match invalid_lexeme.Region.value with
|
|
"" -> sprintf "Parse error %s" reg (* EOF *)
|
|
| lexeme -> sprintf "Parse error %s, before \"%s\""
|
|
reg lexeme)
|
|
| Parser (Some valid_lexeme, invalid_lexeme) ->
|
|
let string =
|
|
sprintf "Parse error %s, after \"%s\""
|
|
reg valid_lexeme.Region.value in
|
|
(match invalid_lexeme.Region.value with
|
|
"" -> string (* EOF *)
|
|
| lexeme -> sprintf "%s and before \"%s\"" string lexeme)
|
|
| Lexer ->
|
|
sprintf "Lexical error %s" reg
|
|
| Scoping ->
|
|
sprintf "Scoping error %s" reg in
|
|
let string =
|
|
string
|
|
^ (if error#message = "" then "."
|
|
else ":\n" ^ error#message) ^ "\n" in
|
|
let string =
|
|
string ^ (if error#hint = "" then ""
|
|
else sprintf "Hint: %s\n" error#hint)
|
|
in string
|