improve EUnexpectedToken; do Lambda parsing

This commit is contained in:
Alain Zscheile 2024-02-25 19:21:31 +01:00
parent 387a7d4baa
commit 68839eb9c8
4 changed files with 66 additions and 24 deletions

View file

@ -47,10 +47,10 @@ module Bare : LocaleT = struct
pp_print_string fmtp "#unexpected_eof; ctx=";
pp_print_string fmtp (fmt_error_ctx x)
| EUnexpectedToken (x, t) ->
pp_print_string fmtp "#unexpected_eof; ctx=";
pp_print_string fmtp "#unexpected_token; ctx=";
pp_print_string fmtp (fmt_error_ctx x);
pp_print_string fmtp "; token=";
pp_print_string fmtp (token_to_string t)
pp_print_string fmtp "; expected_token=";
pp_print_string fmtp (token_kind_to_string t)
| EUnhandled x ->
pp_print_string fmtp "#unhandled; ";
pp_print_string fmtp (String.escaped x)
@ -115,8 +115,8 @@ module En : LocaleT = struct
| EUnexpectedToken (x, t) ->
pp_print_string fmtp "unexpected token inside ";
pp_print_string fmtp (fmt_error_ctx x);
pp_print_string fmtp ": ";
pp_print_string fmtp (token_to_string t)
pp_print_string fmtp ": expected: ";
pp_print_string fmtp (token_kind_to_string t)
| EUnhandled x ->
pp_print_string fmtp "unhandled charachter: ";
pp_print_string fmtp (String.escaped x)

View file

@ -62,26 +62,15 @@ let rec parse_minexpr ps =
let (k, s, ps) = next_in_noeof ps XRefOf in
match k with
| Ident i -> (RefOf (s, env_lookup i s ps), ps)
| _ -> Yanais_syntax_err (EUnexpectedToken (XRefOf, k), s) |> raise
| _ -> Yanais_syntax_err (EUnexpectedToken (XRefOf, TkIdent), s) |> raise
)
| LLiteral l -> (ELiteral l, ps)
| Paren Open -> (
let (inner, ps) = parse_expr ps in
let (_, ps) = require XParens (got (Paren Close)) ps in
let (_, ps) = require_token XParens (Paren Close) ps in
(inner, ps)
)
(*
| Lambda -> (
let (pat, ps) = Pattern.parse in
let (pty, ps) = match parse_ty_annot ps with
| None -> (None, ps)
| Some (s, ptyx, ps) -> (Some (s, ptyx), ps)
in let pmt = (pat, pty) in
let body_span_start = ps.offset in
let (body, ps) = parse_minexpr
)
*)
| _ -> Yanais_syntax_err (EUnexpectedToken (XExpression, k), s) |> raise
| _ -> Yanais_syntax_err (EExpected XExpression, s) |> raise
and parse_ty_annot ps = when_got DubColon (fun (_, ps) ->
let span_start = ps.offset in
@ -97,13 +86,41 @@ and parse_letbinds ps acc = match ps.lt with
| Some (x, y, ps) -> (Some (x, y), ps)
| None -> (None, ps)
in
let (_, ps) = require XLet (got Assign) ps in
let (_, ps) = require_token XLet Assign ps in
let value_start = ps.offset in
let (value, ps) = parse_expr ps in
let value_span = loc_span_of_start_end value_start ps.offset in
let ps = { ps with names = Pattern.exports ps.names pat } in
let (_, ps) = require XLet (got SemiColon) ps in
let (_, ps) = require_token XLet SemiColon ps in
parse_letbinds ps ((pat, pty, (value_span, value)) :: acc)
| _ -> (acc, ps)
and parse_expr _ = failwith "unimplemented"
and parse_expr ps = match ps.lt with
| (Lambda, s)::lt -> (
let ps = { ps with lt; offset = loc_span_end s; } in
let (pat, ps) = Pattern.parse ps in
let (pty, ps) = match parse_ty_annot ps with
| None -> (None, ps)
| Some (s, ptyx, ps) -> (Some (s, ptyx), ps)
in
let body_span_start = ps.offset in
let (body, ps) = parse_expr ps in
let lam = { pat; pty; body_span = Asai.Range.make (body_span_start, ps.offset); body; } in
(Lambda (msr_of_lambda lam, lam), ps)
)
| (TyLambda, s)::lt -> (
let ps = { ps with lt; offset = loc_span_end s; } in
let (_, ps) = require_token XLambda (Paren Open) ps in
let (bind_layout, ps) = parse_expr ps in
let (_, ps) = require_token XLambda (Paren Close) ps in
let (pat, ps) = Pattern.parse ps in
let (pty, ps) = match parse_ty_annot ps with
| None -> (None, ps)
| Some (s, ptyx, ps) -> (Some (s, ptyx), ps)
in
let body_span_start = ps.offset in
let (body, ps) = parse_expr ps in
let lam = { pat; pty; body_span = Asai.Range.make (body_span_start, ps.offset); body; } in
(TyLambda (Int.max (msr_of_lambda lam) (msr_of_expr bind_layout), bind_layout, lam), ps)
)
| _ -> parse_minexpr ps

View file

@ -28,7 +28,7 @@ let parse_opt ps =
| (Brace Close, s)::lt ->
let ps = { ps with lt; offset = loc_span_end s; } in
((osp, oisz, frg), ps)
| (k, s)::_ -> Yanais_syntax_err (EUnexpectedToken (XTagGroupItem, k), s) |> raise
| (_, s)::_ -> Yanais_syntax_err (EExpected XTagGroupItem, s) |> raise
| [] ->
Yanais_syntax_err (EUnexpectedEof XTagGroupItem, osp) |> raise
in inner2 ps FieldsReg.empty

View file

@ -76,6 +76,26 @@ let token_to_string = function
| Match -> "match"
| KTagGroup -> "tag_group"
type token_kind =
| TkToken of token
| TkIntSize
| TkNatural
| TkType
| TkIdent
| TkPatOut
| TkDotIdent
| TkString
let token_kind_to_string = function
| TkToken t -> token_to_string t
| TkIntSize -> "<IntSize>"
| TkNatural -> "<Natural>"
| TkType -> "<Type literal>"
| TkIdent -> "<Identifier>"
| TkPatOut -> "<$Identifier>"
| TkDotIdent -> "<.Identifier>"
| TkString -> "<String>"
type error_ctx =
| XComment
| XExpression
@ -113,7 +133,7 @@ let str_of_ectx = function
type error_kind =
| EExpected of error_ctx
| EUnexpectedEof of error_ctx
| EUnexpectedToken of error_ctx * token
| EUnexpectedToken of error_ctx * token_kind
| EUnhandled of string
| ERecordDupIdent of string
| EPatternDupIdent of string
@ -159,6 +179,11 @@ let require ctx parse_inner ps = match parse_inner ps with
| [] -> Asai.Range.eof ps.offset
in Yanais_syntax_err (EExpected ctx, sp) |> raise
let require_token ctx tok ps = match parse_one ps with
| Some (k, s, ps) when k == tok -> (s, ps)
| Some (_, s, _) -> Yanais_syntax_err (EUnexpectedToken (ctx, TkToken tok), s) |> raise
| None -> Yanais_syntax_err (EUnexpectedToken (ctx, TkToken tok), Asai.Range.eof ps.offset) |> raise
let env_lookup_opt name ps =
let rec inner names count = match names with
| [] -> None