(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs. <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Error_monad
open Micheline
type 'a parsing_result = 'a * error list
let compare compare (aa, ael) (ba, bel) =
Compare.or_else (compare aa ba) (fun () ->
(* FIXME: we need error comparison *)
Stdlib.compare ael bel)
type point = {point : int; byte : int; line : int; column : int}
let point_zero = {point = 0; byte = 0; line = 0; column = 0}
let point_encoding =
let open Data_encoding in
conv
(fun {line; column; point; byte} -> (line, column, point, byte))
(fun (line, column, point, byte) -> {line; column; point; byte})
(obj4
(req "line" uint16)
(req "column" uint16)
(req "point" uint16)
(req "byte" uint16))
type location = {start : point; stop : point}
let location_zero = {start = point_zero; stop = point_zero}
let location_encoding =
let open Data_encoding in
conv
(fun {start; stop} -> (start, stop))
(fun (start, stop) -> {start; stop})
(obj2 (req "start" point_encoding) (req "stop" point_encoding))
type token_value =
| String of string
| Bytes of string
| Int of string
| Ident of string
| Annot of string
| Comment of string
| Eol_comment of string
| Semi
| Open_paren
| Close_paren
| Open_brace
| Close_brace
let token_value_encoding =
let open Data_encoding in
union
[
case
(Tag 0)
~title:"String"
(obj1 (req "string" string))
(function String s -> Some s | _ -> None)
(fun s -> String s);
case
(Tag 1)
~title:"Int"
(obj1 (req "int" string))
(function Int s -> Some s | _ -> None)
(fun s -> Int s);
case
(Tag 2)
~title:"Annot"
(obj1 (req "annot" string))
(function Annot s -> Some s | _ -> None)
(fun s -> Annot s);
case
(Tag 3)
~title:"Comment"
(obj2 (req "comment" string) (dft "end_of_line" bool false))
(function
| Comment s -> Some (s, false)
| Eol_comment s -> Some (s, true)
| _ -> None)
(function s, false -> Comment s | s, true -> Eol_comment s);
case
(Tag 4)
~title:"Punctuation"
(obj1
(req
"punctuation"
(string_enum
[
("(", Open_paren);
(")", Close_paren);
("{", Open_brace);
("}", Close_brace);
(";", Semi);
])))
(fun t -> Some t)
(fun t -> t);
case
(Tag 5)
~title:"Bytes"
(obj1 (req "bytes" string))
(function Bytes s -> Some s | _ -> None)
(fun s -> Bytes s);
case
(Tag 6)
~title:"Ident"
(obj1 (req "ident" string))
(function Ident s -> Some s | _ -> None)
(fun s -> Ident s);
]
type token = {token : token_value; loc : location}
let max_annot_length = 255
type error += Invalid_utf8_sequence of point * string
type error += Unexpected_character of point * string
type error += Undefined_escape_sequence of point * string
type error += Missing_break_after_number of point
type error += Unterminated_string of location
type error += Unterminated_integer of location
type error += Invalid_hex_bytes of location
type error += Unterminated_comment of location
type error += Annotation_length of location
let tokenize source =
let decoder = Uutf.decoder ~encoding:`UTF_8 (`String source) in
let here () =
{
point = Uutf.decoder_count decoder;
byte = Uutf.decoder_byte_count decoder;
line = Uutf.decoder_line decoder;
column = Uutf.decoder_col decoder;
}
in
let tok start stop token = {loc = {start; stop}; token} in
let stack = ref [] in
let errors = ref [] in
let rec next () =
match !stack with
| charloc :: charlocs ->
stack := charlocs ;
charloc
| [] -> (
let loc = here () in
match Uutf.decode decoder with
| `Await -> assert false
| `Malformed s ->
errors := Invalid_utf8_sequence (loc, s) :: !errors ;
next ()
| (`Uchar _ | `End) as other -> (other, loc))
in
let back charloc = stack := charloc :: !stack in
let uchar_to_char c =
if Uchar.is_char c then Some (Uchar.to_char c) else None
in
let allowed_ident_char c =
match uchar_to_char c with
| Some ('a' .. 'z' | 'A' .. 'Z' | '_' | '0' .. '9') -> true
| Some _ | None -> false
in
let allowed_annot_char c =
match uchar_to_char c with
| Some ('a' .. 'z' | 'A' .. 'Z' | '_' | '.' | '%' | '@' | '0' .. '9') ->
true
| Some _ | None -> false
in
let rec skip acc =
match next () with
| `End, _ -> List.rev acc
| `Uchar c, start -> (
match uchar_to_char c with
| Some ('a' .. 'z' | 'A' .. 'Z' | '_') ->
ident acc start (fun s _ -> Ident s)
| Some ('@' | ':' | '$' | '&' | '%' | '!' | '?') ->
annot acc start (fun str stop ->
if String.length str > max_annot_length then
errors := Annotation_length {start; stop} :: !errors ;
Annot str)
| Some '-' -> (
match next () with
| `End, stop ->
errors := Unterminated_integer {start; stop} :: !errors ;
List.rev acc
| (`Uchar c, stop) as first -> (
match uchar_to_char c with
| Some '0' -> base acc start
| Some '1' .. '9' -> integer acc start
| Some _ | None ->
errors := Unterminated_integer {start; stop} :: !errors ;
back first ;
skip acc))
| Some '0' -> base acc start
| Some '1' .. '9' -> integer acc start
| Some (' ' | '\n') -> skip acc
| Some ';' -> skip (tok start (here ()) Semi :: acc)
| Some '{' -> skip (tok start (here ()) Open_brace :: acc)
| Some '}' -> skip (tok start (here ()) Close_brace :: acc)
| Some '(' -> skip (tok start (here ()) Open_paren :: acc)
| Some ')' -> skip (tok start (here ()) Close_paren :: acc)
| Some '"' -> string acc [] start
| Some '#' -> eol_comment acc start
| Some '/' -> (
match next () with
| `Uchar c, _ when Uchar.equal c (Uchar.of_char '*') ->
comment acc start 0
| ((`Uchar _ | `End), _) as charloc ->
errors := Unexpected_character (start, "/") :: !errors ;
back charloc ;
skip acc)
| Some _ | None ->
let byte = Uutf.decoder_byte_count decoder in
let s = String.sub source start.byte (byte - start.byte) in
errors := Unexpected_character (start, s) :: !errors ;
skip acc)
and base acc start =
match next () with
| (`Uchar c, stop) as charloc -> (
match uchar_to_char c with
| Some '0' .. '9' -> integer acc start
| Some 'x' -> bytes acc start
| Some ('a' .. 'w' | 'y' | 'z' | 'A' .. 'Z' | '_') ->
errors := Missing_break_after_number stop :: !errors ;
back charloc ;
skip (tok start stop (Int "0") :: acc)
| Some _ | None ->
back charloc ;
skip (tok start stop (Int "0") :: acc))
| (_, stop) as other ->
back other ;
skip (tok start stop (Int "0") :: acc)
and integer acc start =
let tok stop =
let value = String.sub source start.byte (stop.byte - start.byte) in
tok start stop (Int value)
in
match next () with
| (`Uchar c, stop) as charloc -> (
let missing_break () =
errors := Missing_break_after_number stop :: !errors ;
back charloc ;
skip (tok stop :: acc)
in
match Uchar.to_char c with
| '0' .. '9' -> integer acc start
| 'a' .. 'z' | 'A' .. 'Z' | '_' -> missing_break ()
| _ ->
back charloc ;
skip (tok stop :: acc))
| (`End, stop) as other ->
back other ;
skip (tok stop :: acc)
and bytes acc start =
let tok stop =
let value = String.sub source start.byte (stop.byte - start.byte) in
tok start stop (Bytes value)
in
match next () with
| (`Uchar c, stop) as charloc -> (
let missing_break () =
errors := Missing_break_after_number stop :: !errors ;
back charloc ;
skip (tok stop :: acc)
in
match Uchar.to_char c with
| '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> bytes acc start
| 'g' .. 'z' | 'G' .. 'Z' -> missing_break ()
| _ ->
back charloc ;
skip (tok stop :: acc))
| (`End, stop) as other ->
back other ;
skip (tok stop :: acc)
and string acc sacc start =
let tok () =
tok start (here ()) (String (String.concat "" (List.rev sacc)))
in
match next () with
| `End, stop ->
errors := Unterminated_string {start; stop} :: !errors ;
skip (tok () :: acc)
| `Uchar c, stop -> (
match uchar_to_char c with
| Some '"' -> skip (tok () :: acc)
| Some ('\n' | '\r') ->
errors := Unterminated_string {start; stop} :: !errors ;
skip (tok () :: acc)
| Some '\\' -> (
match next () with
| `End, stop ->
errors := Unterminated_string {start; stop} :: !errors ;
skip (tok () :: acc)
| `Uchar c, loc -> (
match uchar_to_char c with
| Some '"' -> string acc ("\"" :: sacc) start
| Some 'r' -> string acc ("\r" :: sacc) start
| Some 'n' -> string acc ("\n" :: sacc) start
| Some 't' -> string acc ("\t" :: sacc) start
| Some 'b' -> string acc ("\b" :: sacc) start
| Some '\\' -> string acc ("\\" :: sacc) start
| Some _ | None ->
let byte = Uutf.decoder_byte_count decoder in
let s = String.sub source loc.byte (byte - loc.byte) in
errors := Undefined_escape_sequence (loc, s) :: !errors ;
string acc sacc start))
| Some _ | None ->
let byte = Uutf.decoder_byte_count decoder in
let s = String.sub source stop.byte (byte - stop.byte) in
string acc (s :: sacc) start)
and generic_ident allow_char acc start (ret : string -> point -> token_value)
=
let tok stop =
let name = String.sub source start.byte (stop.byte - start.byte) in
tok start stop (ret name stop)
in
match next () with
| (`Uchar c, stop) as charloc ->
if allow_char c then generic_ident allow_char acc start ret
else (
back charloc ;
skip (tok stop :: acc))
| (_, stop) as other ->
back other ;
skip (tok stop :: acc)
and ident acc start ret = generic_ident allowed_ident_char acc start ret
and annot acc start ret = generic_ident allowed_annot_char acc start ret
and comment acc start lvl =
match next () with
| `End, stop ->
errors := Unterminated_comment {start; stop} :: !errors ;
let text = String.sub source start.byte (stop.byte - start.byte) in
skip (tok start stop (Comment text) :: acc)
| `Uchar c, _ -> (
match uchar_to_char c with
| Some '*' -> (
match next () with
| `Uchar c, _ when Uchar.equal c (Uchar.of_char '/') ->
if lvl = 0 then
let stop = here () in
let text =
String.sub source start.byte (stop.byte - start.byte)
in
skip (tok start stop (Comment text) :: acc)
else comment acc start (lvl - 1)
| other ->
back other ;
comment acc start lvl)
| Some '/' -> (
match next () with
| `Uchar c, _ when Uchar.equal c (Uchar.of_char '*') ->
comment acc start (lvl + 1)
| other ->
back other ;
comment acc start lvl)
| Some _ | None -> comment acc start lvl)
and eol_comment acc start =
let tok stop =
let text = String.sub source start.byte (stop.byte - start.byte) in
tok start stop (Eol_comment text)
in
match next () with
| `Uchar c, stop -> (
match uchar_to_char c with
| Some '\n' -> skip (tok stop :: acc)
| Some _ | None -> eol_comment acc start)
| (_, stop) as other ->
back other ;
skip (tok stop :: acc)
in
let tokens = skip [] in
(tokens, List.rev !errors)
type node = (location, string) Micheline.node
(* Beginning of a sequence of consecutive primitives *)
let min_point : node list -> point = function
| [] -> point_zero
| Int ({start; _}, _) :: _
| String ({start; _}, _) :: _
| Bytes ({start; _}, _) :: _
| Prim ({start; _}, _, _, _) :: _
| Seq ({start; _}, _) :: _ ->
start
(* End of a sequence of consecutive primitives *)
let rec max_point : node list -> point = function
| [] -> point_zero
| _ :: (_ :: _ as rest) -> max_point rest
| [Int ({stop; _}, _)]
| [String ({stop; _}, _)]
| [Bytes ({stop; _}, _)]
| [Prim ({stop; _}, _, _, _)]
| [Seq ({stop; _}, _)] ->
stop
(* An item in the parser's state stack.
Not every value of type [mode list] is a valid parsing context.
It must respect the following additional invariants.
- a state stack always ends in [Toplevel _],
- [Toplevel _] does not appear anywhere else,
- [Unwrapped _] cannot appear directly on top of [Wrapped _],
- [Wrapped _] cannot appear directly on top of [Sequence _],
- [Wrapped _] cannot appear directly on top of [Sequence _]. *)
type mode =
| Toplevel of node list
| Expression of node option
| Sequence of token * node list
| Unwrapped of location * string * node list * string list
| Wrapped of token * string * node list * string list
(* Enter a new parsing state. *)
let push_mode mode stack = mode :: stack
(* Leave a parsing state. *)
let pop_mode = function [] -> assert false | _ :: rest -> rest
(* Usually after a [pop_mode], jump back into the previous parsing
state, injecting the current reduction (insert the just parsed item
of a sequence or argument of a primitive application). *)
let fill_mode result = function
| [] -> assert false
| Expression _ :: _ :: _ -> assert false
| [Expression (Some _)] -> assert false
| Toplevel _ :: _ :: _ -> assert false
| [Expression None] -> [Expression (Some result)]
| [Toplevel exprs] -> [Toplevel (result :: exprs)]
| Sequence (token, exprs) :: rest -> Sequence (token, result :: exprs) :: rest
| Wrapped (token, name, exprs, annot) :: rest ->
Wrapped (token, name, result :: exprs, annot) :: rest
| Unwrapped (start, name, exprs, annot) :: rest ->
Unwrapped (start, name, result :: exprs, annot) :: rest
type error += Unclosed of token
type error += Unexpected of token
type error += Extra of token
type error += Misaligned of node
type error += Empty
let rec annots = function
| {token = Annot annot; _} :: rest ->
let annots, rest = annots rest in
(annot :: annots, rest)
| rest -> ([], rest)
let rec parse ?(check = true) errors tokens stack =
(* Two steps:
- 1. parse without checking indentation [parse]
- 2. check indentation [check] (inlined in 1) *)
match (stack, tokens) with
(* Start by preventing all absurd cases, so now the pattern
matching exhaustivity can tell us that we treater all
possible tokens for all possible valid states. *)
| [], _
| [Wrapped _], _
| [Unwrapped _], _
| Unwrapped _ :: Unwrapped _ :: _, _
| Unwrapped _ :: Wrapped _ :: _, _
| Toplevel _ :: _ :: _, _
| Expression _ :: _ :: _, _ ->
assert false
(* Return *)
| Expression (Some result) :: _, [] -> ([result], List.rev errors)
| Expression (Some _) :: _, token :: rem ->
let errors = Unexpected token :: errors in
parse ~check errors rem (* skip *) stack
| Expression None :: _, [] ->
let errors = Empty :: errors in
let ghost = {start = point_zero; stop = point_zero} in
([Seq (ghost, [])], List.rev errors)
| [Toplevel [(Seq (_, exprs) as expr)]], [] ->
let errors =
if check then do_check ~toplevel:false errors expr else errors
in
(exprs, List.rev errors)
| [Toplevel exprs], [] ->
let exprs = List.rev exprs in
let loc = {start = min_point exprs; stop = max_point exprs} in
let expr = Seq (loc, exprs) in
let errors =
if check then do_check ~toplevel:true errors expr else errors
in
(exprs, List.rev errors)
(* Ignore comments *)
| _, {token = Eol_comment _ | Comment _; _} :: rest ->
parse ~check errors rest stack
| ( (Expression None | Sequence _ | Toplevel _) :: _,
({token = Int _ | String _ | Bytes _; _} as token)
:: {token = Eol_comment _ | Comment _; _}
:: rest )
| ( (Wrapped _ | Unwrapped _) :: _,
({token = Open_paren; _} as token)
:: {token = Eol_comment _ | Comment _; _}
:: rest ) ->
parse ~check errors (token :: rest) stack
(* Erroneous states *)
| ( (Wrapped _ | Unwrapped _) :: _,
({token = Open_paren; _} as token)
:: {token = Open_paren | Open_brace; _}
:: rem )
| ( Unwrapped _ :: Expression _ :: _,
({token = Semi | Close_brace | Close_paren; _} as token) :: rem )
| ( Expression None :: _,
({token = Semi | Close_brace | Close_paren | Open_paren; _} as token)
:: rem ) ->
let errors = Unexpected token :: errors in
parse ~check errors rem (* skip *) stack
| ( (Sequence _ | Toplevel _) :: _,
({token = Semi; _} as valid) :: ({token = Semi; _} as token) :: rem ) ->
let errors = Extra token :: errors in
parse ~check errors (* skip *) (valid :: rem) stack
| ( (Wrapped _ | Unwrapped _) :: _,
{token = Open_paren; _}
:: ({token = Int _ | String _ | Bytes _ | Annot _ | Close_paren; _} as
token)
:: rem )
| ( (Expression None | Sequence _ | Toplevel _) :: _,
{token = Int _ | String _ | Bytes _; _}
:: ({
token =
( Ident _ | Int _ | String _ | Bytes _ | Annot _ | Close_paren
| Open_paren | Open_brace );
_;
} as token)
:: rem )
| ( Unwrapped (_, _, _, _) :: Toplevel _ :: _,
({token = Close_brace; _} as token) :: rem )
| Unwrapped (_, _, _, _) :: _, ({token = Close_paren; _} as token) :: rem
| [Toplevel _], ({token = Close_paren; _} as token) :: rem
| [Toplevel _], ({token = Open_paren; _} as token) :: rem
| [Toplevel _], ({token = Close_brace; _} as token) :: rem
| Sequence _ :: _, ({token = Open_paren; _} as token) :: rem
| Sequence _ :: _, ({token = Close_paren; _} as token) :: rem
| ( (Wrapped _ | Unwrapped _) :: _,
({token = Open_paren; _} as token)
:: (({token = Close_brace | Semi; _} :: _ | []) as rem) )
| _, ({token = Annot _; _} as token) :: rem ->
let errors = Unexpected token :: errors in
parse ~check errors rem (* skip *) stack
| Wrapped (token, _, _, _) :: _, ([] | {token = Close_brace | Semi; _} :: _)
->
let errors = Unclosed token :: errors in
let fake = {token with token = Close_paren} in
let tokens = (* insert *) fake :: tokens in
parse ~check errors tokens stack
| (Sequence (token, _) :: _ | Unwrapped _ :: Sequence (token, _) :: _), [] ->
let errors = Unclosed token :: errors in
let fake = {token with token = Close_brace} in
let tokens = (* insert *) fake :: tokens in
parse ~check errors tokens stack
(* Valid states *)
| ( (Toplevel _ | Sequence (_, _)) :: _,
{token = Ident name; loc} :: ({token = Annot _; _} :: _ as rest) ) ->
let annots, rest = annots rest in
let mode = Unwrapped (loc, name, [], annots) in
parse ~check errors rest (push_mode mode stack)
| ( (Expression None | Toplevel _ | Sequence (_, _)) :: _,
{token = Ident name; loc} :: rest ) ->
let mode = Unwrapped (loc, name, [], []) in
parse ~check errors rest (push_mode mode stack)
| (Unwrapped _ | Wrapped _) :: _, {token = Int value; loc} :: rest
| ( (Expression None | Sequence _ | Toplevel _) :: _,
{token = Int value; loc}
:: (([] | {token = Semi | Close_brace; _} :: _) as rest) ) ->
let expr : node = Int (loc, Z.of_string value) in
let errors =
if check then do_check ~toplevel:false errors expr else errors
in
parse ~check errors rest (fill_mode expr stack)
| (Unwrapped _ | Wrapped _) :: _, {token = String contents; loc} :: rest
| ( (Expression None | Sequence _ | Toplevel _) :: _,
{token = String contents; loc}
:: (([] | {token = Semi | Close_brace; _} :: _) as rest) ) ->
let expr : node = String (loc, contents) in
let errors =
if check then do_check ~toplevel:false errors expr else errors
in
parse ~check errors rest (fill_mode expr stack)
| (Unwrapped _ | Wrapped _) :: _, {token = Bytes contents; loc} :: rest
| ( (Expression None | Sequence _ | Toplevel _) :: _,
{token = Bytes contents; loc}
:: (([] | {token = Semi | Close_brace; _} :: _) as rest) ) ->
let errors, bytes =
match
Hex.to_bytes
(`Hex (String.sub contents 2 (String.length contents - 2)))
with
| None -> (Invalid_hex_bytes loc :: errors, Bytes.empty)
| Some bytes -> (errors, bytes)
in
let expr : node = Bytes (loc, bytes) in
let errors =
if check then do_check ~toplevel:false errors expr else errors
in
parse ~check errors rest (fill_mode expr stack)
| ( Sequence ({loc = {start; _}; _}, exprs) :: _,
{token = Close_brace; loc = {stop; _}} :: rest ) ->
let exprs = List.rev exprs in
let expr = Micheline.Seq ({start; stop}, exprs) in
let errors =
if check then do_check ~toplevel:false errors expr else errors
in
parse ~check errors rest (fill_mode expr (pop_mode stack))
| (Sequence _ | Toplevel _) :: _, {token = Semi; _} :: rest ->
parse ~check errors rest stack
| ( Unwrapped ({start; stop}, name, exprs, annot) :: Expression _ :: _,
([] as rest) )
| ( Unwrapped ({start; stop}, name, exprs, annot) :: Toplevel _ :: _,
(({token = Semi; _} :: _ | []) as rest) )
| ( Unwrapped ({start; stop}, name, exprs, annot) :: Sequence _ :: _,
({token = Close_brace | Semi; _} :: _ as rest) )
| ( Wrapped ({loc = {start; stop}; _}, name, exprs, annot) :: _,
{token = Close_paren; _} :: rest ) ->
let exprs = List.rev exprs in
let stop = if exprs = [] then stop else max_point exprs in
let expr = Micheline.Prim ({start; stop}, name, exprs, annot) in
let errors =
if check then do_check ~toplevel:false errors expr else errors
in
parse ~check errors rest (fill_mode expr (pop_mode stack))
| ( (Wrapped _ | Unwrapped _) :: _,
({token = Open_paren; _} as token)
:: {token = Ident name; _}
:: ({token = Annot _; _} :: _ as rest) ) ->
let annots, rest = annots rest in
let mode = Wrapped (token, name, [], annots) in
parse ~check errors rest (push_mode mode stack)
| ( (Wrapped _ | Unwrapped _) :: _,
({token = Open_paren; _} as token) :: {token = Ident name; _} :: rest ) ->
let mode = Wrapped (token, name, [], []) in
parse ~check errors rest (push_mode mode stack)
| (Wrapped _ | Unwrapped _) :: _, {token = Ident name; loc} :: rest ->
let expr = Micheline.Prim (loc, name, [], []) in
let errors =
if check then do_check ~toplevel:false errors expr else errors
in
parse ~check errors rest (fill_mode expr stack)
| ( (Wrapped _ | Unwrapped _ | Toplevel _ | Sequence _ | Expression None) :: _,
({token = Open_brace; _} as token) :: rest ) ->
let mode = Sequence (token, []) in
parse ~check errors rest (push_mode mode stack)
(* indentation checker *)
and do_check ?(toplevel = false) errors = function
| Seq ({start; stop}, []) as expr ->
if start.column >= stop.column then Misaligned expr :: errors else errors
| ( Prim ({start; stop}, _, first :: rest, _)
| Seq ({start; stop}, first :: rest) ) as expr ->
let {column = first_column; line = first_line; _} = min_point [first] in
if start.column >= stop.column then Misaligned expr :: errors
else if (not toplevel) && start.column >= first_column then
Misaligned expr :: errors
else
(* In a sequence or in the arguments of a primitive, we
require all items to be aligned, but we relax the rule to
allow consecutive items to be written on the same line. *)
let rec in_line_or_aligned prev_start_line errors = function
| [] -> errors
| expr :: rest ->
let {column; line = start_line; _} = min_point [expr] in
let {line = stop_line; _} = max_point [expr] in
let errors =
if stop_line <> prev_start_line && column <> first_column then
Misaligned expr :: errors
else errors
in
in_line_or_aligned start_line errors rest
in
in_line_or_aligned first_line errors rest
| Prim (_, _, [], _) | String _ | Int _ | Bytes _ -> errors
let parse_expression ?check tokens =
let result =
match tokens with
| ({token = Open_paren; _} as token)
:: {token = Ident name; _}
:: {token = Annot annot; _}
:: rest ->
let annots, rest = annots rest in
let mode = Wrapped (token, name, [], annot :: annots) in
parse ?check [] rest [mode; Expression None]
| ({token = Open_paren; _} as token) :: {token = Ident name; _} :: rest ->
let mode = Wrapped (token, name, [], []) in
parse ?check [] rest [mode; Expression None]
| _ -> parse ?check [] tokens [Expression None]
in
match result with [single], errors -> (single, errors) | _ -> assert false
let parse_toplevel ?check tokens = parse ?check [] tokens [Toplevel []]
let print_point ppf {line; column; _} =
Format.fprintf ppf "At line %d character %d" line column
let print_token_kind ppf = function
| Open_paren | Close_paren -> Format.fprintf ppf "parenthesis"
| Open_brace | Close_brace -> Format.fprintf ppf "curly brace"
| String _ -> Format.fprintf ppf "string constant"
| Bytes _ -> Format.fprintf ppf "bytes constant"
| Int _ -> Format.fprintf ppf "integer constant"
| Ident _ -> Format.fprintf ppf "identifier"
| Annot _ -> Format.fprintf ppf "annotation"
| Comment _ | Eol_comment _ -> Format.fprintf ppf "comment"
| Semi -> Format.fprintf ppf "semi colon"
let print_location ppf loc =
if loc.start.line = loc.stop.line then
if loc.start.column = loc.stop.column then
Format.fprintf
ppf
"At line %d character %d"
loc.start.line
loc.start.column
else
Format.fprintf
ppf
"At line %d characters %d to %d"
loc.start.line
loc.start.column
loc.stop.column
else
Format.fprintf
ppf
"From line %d character %d to line %d character %d"
loc.start.line
loc.start.column
loc.stop.line
loc.stop.column
let no_parsing_error (ast, errors) =
match errors with [] -> Ok ast | errors -> Error errors
let () =
register_error_kind
`Permanent
~id:"micheline.parse_error.invalid_utf8_sequence"
~title:"Micheline parser error: invalid UTF-8 sequence"
~description:
"While parsing a piece of Micheline source, a sequence of bytes that is \
not valid UTF-8 was encountered."
~pp:(fun ppf (point, str) ->
Format.fprintf ppf "%a, invalid UTF-8 sequence %S" print_point point str)
Data_encoding.(obj2 (req "point" point_encoding) (req "sequence" string))
(function
| Invalid_utf8_sequence (point, str) -> Some (point, str) | _ -> None)
(fun (point, str) -> Invalid_utf8_sequence (point, str)) ;
register_error_kind
`Permanent
~id:"micheline.parse_error.unexpected_character"
~title:"Micheline parser error: unexpected character"
~description:
"While parsing a piece of Micheline source, an unexpected character was \
encountered."
~pp:(fun ppf (point, str) ->
Format.fprintf ppf "%a, unexpected character %s" print_point point str)
Data_encoding.(obj2 (req "point" point_encoding) (req "character" string))
(function
| Unexpected_character (point, str) -> Some (point, str) | _ -> None)
(fun (point, str) -> Unexpected_character (point, str)) ;
register_error_kind
`Permanent
~id:"micheline.parse_error.undefined_escape_sequence"
~title:"Micheline parser error: undefined escape sequence"
~description:
"While parsing a piece of Micheline source, an unexpected escape \
sequence was encountered in a string."
~pp:(fun ppf (point, str) ->
Format.fprintf
ppf
"%a, undefined escape sequence \"%s\""
print_point
point
str)
Data_encoding.(obj2 (req "point" point_encoding) (req "sequence" string))
(function
| Undefined_escape_sequence (point, str) -> Some (point, str) | _ -> None)
(fun (point, str) -> Undefined_escape_sequence (point, str)) ;
register_error_kind
`Permanent
~id:"micheline.parse_error.missing_break_after_number"
~title:"Micheline parser error: missing break after number"
~description:
"While parsing a piece of Micheline source, a number was not visually \
separated from its follower token, leading to misreadability."
~pp:(fun ppf point ->
Format.fprintf ppf "%a, missing break after number" print_point point)
Data_encoding.(obj1 (req "point" point_encoding))
(function Missing_break_after_number point -> Some point | _ -> None)
(fun point -> Missing_break_after_number point) ;
register_error_kind
`Permanent
~id:"micheline.parse_error.unterminated_string"
~title:"Micheline parser error: unterminated string"
~description:
"While parsing a piece of Micheline source, a string was not terminated."
~pp:(fun ppf loc ->
Format.fprintf ppf "%a, unterminated string" print_location loc)
Data_encoding.(obj1 (req "location" location_encoding))
(function Unterminated_string loc -> Some loc | _ -> None)
(fun loc -> Unterminated_string loc) ;
register_error_kind
`Permanent
~id:"micheline.parse_error.unterminated_integer"
~title:"Micheline parser error: unterminated integer"
~description:
"While parsing a piece of Micheline source, an integer was not \
terminated."
~pp:(fun ppf loc ->
Format.fprintf ppf "%a, unterminated integer" print_location loc)
Data_encoding.(obj1 (req "location" location_encoding))
(function Unterminated_integer loc -> Some loc | _ -> None)
(fun loc -> Unterminated_integer loc) ;
register_error_kind
`Permanent
~id:"micheline.parse_error.invalid_hex_bytes"
~title:"Micheline parser error: invalid hex bytes"
~description:
"While parsing a piece of Micheline source, a byte sequence (0x...) was \
not valid as a hex byte."
~pp:(fun ppf loc ->
Format.fprintf ppf "%a, invalid hex bytes" print_location loc)
Data_encoding.(obj1 (req "location" location_encoding))
(function Invalid_hex_bytes loc -> Some loc | _ -> None)
(fun loc -> Invalid_hex_bytes loc) ;
register_error_kind
`Permanent
~id:"micheline.parse_error.unterminated_comment"
~title:"Micheline parser error: unterminated comment"
~description:
"While parsing a piece of Micheline source, a commentX was not \
terminated."
~pp:(fun ppf loc ->
Format.fprintf ppf "%a, unterminated comment" print_location loc)
Data_encoding.(obj1 (req "location" location_encoding))
(function Unterminated_comment loc -> Some loc | _ -> None)
(fun loc -> Unterminated_comment loc) ;
register_error_kind
`Permanent
~id:"micheline.parse_error.annotation_exceeds_max_length"
~title:"Micheline parser error: annotation exceeds max length"
~description:
(Format.sprintf
"While parsing a piece of Micheline source, an annotation exceeded \
the maximum length (%d)."
max_annot_length)
~pp:(fun ppf loc ->
Format.fprintf
ppf
"%a, annotation exceeded maximum length (%d chars)"
print_location
loc
max_annot_length)
Data_encoding.(obj1 (req "location" location_encoding))
(function Annotation_length loc -> Some loc | _ -> None)
(fun loc -> Annotation_length loc) ;
register_error_kind
`Permanent
~id:"micheline.parse_error.unclosed_token"
~title:"Micheline parser error: unclosed token"
~description:
"While parsing a piece of Micheline source, a parenthesis or a brace was \
unclosed."
~pp:(fun ppf (loc, token) ->
Format.fprintf
ppf
"%a, unclosed %a"
print_location
loc
print_token_kind
token)
Data_encoding.(
obj2 (req "location" location_encoding) (req "token" token_value_encoding))
(function Unclosed {loc; token} -> Some (loc, token) | _ -> None)
(fun (loc, token) -> Unclosed {loc; token}) ;
register_error_kind
`Permanent
~id:"micheline.parse_error.unexpected_token"
~title:"Micheline parser error: unexpected token"
~description:
"While parsing a piece of Micheline source, an unexpected token was \
encountered."
~pp:(fun ppf (loc, token) ->
Format.fprintf
ppf
"%a, unexpected %a"
print_location
loc
print_token_kind
token)
Data_encoding.(
obj2 (req "location" location_encoding) (req "token" token_value_encoding))
(function Unexpected {loc; token} -> Some (loc, token) | _ -> None)
(fun (loc, token) -> Unexpected {loc; token}) ;
register_error_kind
`Permanent
~id:"micheline.parse_error.extra_token"
~title:"Micheline parser error: extra token"
~description:
"While parsing a piece of Micheline source, an extra semi colon or \
parenthesis was encountered."
~pp:(fun ppf (loc, token) ->
Format.fprintf
ppf
"%a, extra %a"
print_location
loc
print_token_kind
token)
Data_encoding.(
obj2 (req "location" location_encoding) (req "token" token_value_encoding))
(function Extra {loc; token} -> Some (loc, token) | _ -> None)
(fun (loc, token) -> Extra {loc; token}) ;
(* [Misaligned] is registered in the encoding module to break a dependency
cycle *)
register_error_kind
`Permanent
~id:"micheline.parse_error.empty_expression"
~title:"Micheline parser error: empty_expression"
~description:
"Tried to interpret an empty piece or Micheline source as a single \
expression."
~pp:(fun ppf () -> Format.fprintf ppf "empty expression")
Data_encoding.empty
(function Empty -> Some () | _ -> None)
(fun () -> Empty)
(* helper functions for the encoding *)
let check_annot s =
String.length s <= max_annot_length
&&
match tokenize s with
| [{token = Annot s'; _}], [] (* no errors *) -> String.equal s s'
| _ -> false
