From 68839eb9c874e968d8716f5db0246798ccb94db8 Mon Sep 17 00:00:00 2001 From: Alain Zscheile Date: Sun, 25 Feb 2024 19:21:31 +0100 Subject: [PATCH] improve EUnexpectedToken; do Lambda parsing --- ocaml/lib/locale.ml | 10 ++++---- ocaml/libsyntax/expr.ml | 51 ++++++++++++++++++++++++------------- ocaml/libsyntax/tagGroup.ml | 2 +- ocaml/libsyntax/tys.ml | 27 +++++++++++++++++++- 4 files changed, 66 insertions(+), 24 deletions(-) diff --git a/ocaml/lib/locale.ml b/ocaml/lib/locale.ml index 0c8cc5c..766a99e 100644 --- a/ocaml/lib/locale.ml +++ b/ocaml/lib/locale.ml @@ -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) diff --git a/ocaml/libsyntax/expr.ml b/ocaml/libsyntax/expr.ml index 0342a4b..47289f6 100644 --- a/ocaml/libsyntax/expr.ml +++ b/ocaml/libsyntax/expr.ml @@ -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 diff --git a/ocaml/libsyntax/tagGroup.ml b/ocaml/libsyntax/tagGroup.ml index df286c4..b2fc8e5 100644 --- a/ocaml/libsyntax/tagGroup.ml +++ b/ocaml/libsyntax/tagGroup.ml @@ -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 diff --git a/ocaml/libsyntax/tys.ml b/ocaml/libsyntax/tys.ml index 8e3a830..e037480 100644 --- a/ocaml/libsyntax/tys.ml +++ b/ocaml/libsyntax/tys.ml @@ -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 -> "" + | TkNatural -> "" + | TkType -> "" + | TkIdent -> "" + | TkPatOut -> "<$Identifier>" + | TkDotIdent -> "<.Identifier>" + | TkString -> "" + 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