improve EUnexpectedToken; do Lambda parsing

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)

ocaml/libsyntax/expr.ml

@@ -8,10 +8,9 @@ type sel_ident = loc_span * stack_ref
 type max_stack_ref = stack_ref
 type 'a record = 'a Record.t
 
-type pattern_mt = Pattern.t * ((loc_span * expr) option)
-
-and lambda =
-  { pat       : pattern_mt
+type lambda =
+  { pat       : Pattern.t
+  ; pty       : (loc_span * expr) option
   ; body_span : loc_span
   ; body      : expr
   }
@@ -23,27 +22,36 @@ and expr =
   | RefOf of sel_ident
   | Lambda of max_stack_ref * lambda
   | TyLambda of max_stack_ref * expr * lambda (* note that the first element is the layout of the binders *)
-  | Apply of max_stack_ref * expr * loc_span * expr
-  | RefTy of max_stack_ref * stack_ref * expr
-  | Record of max_stack_ref * expr record
-  | TyRecord of max_stack_ref * expr record
+  | Apply of expr * loc_span * expr
+  | RefTy of stack_ref * expr
+  | Record of expr record
+  | TyRecord of expr record
 
 (* parser *)
 
 module FieldsReg = Set.Make(String)
 module FieldsReg2 = Map.Make(String)
 
-let msr_of_expr = function
+let rec msr_of_expr = function
   | Infer -> 0
   | ELiteral _ -> 0
   | Use (_, x) -> x + 1
   | RefOf (_, x) -> x + 1
   | Lambda (x, _) -> x
   | TyLambda (x, _, _) -> x
-  | Apply (x, _, _, _) -> x
-  | RefTy (x, _, _) -> x
-  | Record (x, _) -> x
-  | TyRecord (x, _) -> x
+  | Apply (x, _, y) -> Int.max (msr_of_expr x) (msr_of_expr y)
+  | RefTy (x, y) -> Int.max (x + 1) (msr_of_expr y)
+  | Record x -> msr_of_record x 0
+  | TyRecord x -> msr_of_record x 0
+
+and msr_of_record rcd acc = match rcd with
+  | [] -> acc
+  | (_, _, x)::xs -> (Int.max acc (msr_of_expr x)) |> msr_of_record xs
+
+let msr_of_lambda lam =
+  let msr_body = msr_of_expr lam.body in
+  let msr_pty = Option.fold ~none:0 ~some:(fun (_, x) -> (msr_of_expr x) + 1) lam.pty in
+  Int.max msr_body msr_pty
 
 (* a minimal expression are all parts which are "self contained" enough (e.g. not an apply) *)
 let rec parse_minexpr ps =
@@ -54,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
@@ -89,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

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

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   -> "<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