165 lines
6.3 KiB
OCaml
165 lines
6.3 KiB
OCaml
|
|
(* unevaluated expressions with no runtime variables *)
|
|
|
|
open Tys
|
|
|
|
type stack_ref = int [@@deriving show]
|
|
type sel_ident = loc_span * stack_ref [@@deriving show]
|
|
type max_stack_ref = int [@@deriving show]
|
|
type 'a record = 'a Record.t [@@deriving show]
|
|
|
|
type lambda =
|
|
{ pat : Pattern.t
|
|
; pty : (loc_span * expr) option
|
|
; body_span : loc_span
|
|
; body : expr
|
|
} [@@deriving show]
|
|
|
|
and expr =
|
|
| Infer
|
|
| ELiteral of Literal.lit
|
|
| Use of sel_ident
|
|
| 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 expr * loc_span * expr
|
|
| RefTy of stack_ref * expr
|
|
| Record of expr record
|
|
| TyRecord of expr record
|
|
[@@deriving show]
|
|
|
|
(* parser *)
|
|
|
|
module FieldsReg = Set.Make(String)
|
|
module FieldsReg2 = Map.Make(String)
|
|
|
|
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, _, 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 =
|
|
let (k, s, ps) = next_in_noeof ps XExpression in
|
|
match k with
|
|
| Ident i -> (Use (s, env_lookup i s ps), ps)
|
|
| RefOf -> (
|
|
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, TkIdent), s) |> raise
|
|
)
|
|
| LLiteral l -> (ELiteral l, ps)
|
|
| Paren Open -> (
|
|
let (inner, ps) = parse_expr ps in
|
|
let (_, ps) = require_token XParens (Paren Close) ps in
|
|
(inner, ps)
|
|
)
|
|
| _ -> Yanais_syntax_err (EExpected XExpression, s) |> raise
|
|
|
|
and parse_ty_annot ps = when_got DubColon (fun (_, ps) ->
|
|
let span_start = ps.offset in
|
|
let (ptyx, ps) = parse_expr ps in
|
|
let span = loc_span_of_start_end span_start ps.offset in
|
|
(span, ptyx, ps)
|
|
) ps
|
|
|
|
and parse_letbinds ps acc = match ps.lt () with
|
|
| Seq.Cons ((Let, s), lt) ->
|
|
let (pat, ps) = Pattern.parse { ps with lt; offset = loc_span_end s; } in
|
|
let (pty, ps) = match parse_ty_annot ps with
|
|
| Some (x, y, ps) -> (Some (x, y), ps)
|
|
| None -> (None, 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_token XLet SemiColon ps in
|
|
parse_letbinds ps ((pat, pty, (value_span, value)) :: acc)
|
|
| _ -> (acc, ps)
|
|
|
|
and parse_expr ps = match ps.lt () with
|
|
| Seq.Cons ((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 (_, ps) = require_token XLambda RArr ps in
|
|
let body_span_start = ps.offset in
|
|
let old_names = ps.names in
|
|
let new_names = Pattern.exports ps.names pat in
|
|
let ps = { ps with names = Pattern.exports ps.names pat; } in
|
|
let (body, ps) = parse_expr ps in
|
|
if ps.names <> new_names then failwith "invalid name book-keeping detected";
|
|
let ps = { ps with names = old_names; } in
|
|
let lam = { pat; pty; body_span = Asai.Range.make (body_span_start, ps.offset); body; } in
|
|
(Lambda (msr_of_lambda lam, lam), ps)
|
|
)
|
|
| Seq.Cons ((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 (_, ps) = require_token XLambda RArr ps in
|
|
let body_span_start = ps.offset in
|
|
let old_names = ps.names in
|
|
let new_names = Pattern.exports ps.names pat in
|
|
let ps = { ps with names = Pattern.exports ps.names pat; } in
|
|
let (body, ps) = parse_expr ps in
|
|
if ps.names <> new_names then failwith "invalid name book-keeping detected";
|
|
let ps = { ps with names = old_names; } 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)
|
|
)
|
|
| Seq.Cons ((Include, s1), lt) -> (
|
|
let ps = { ps with lt; offset = loc_span_end s1; } in
|
|
let (_, ps) = require_token XLambda (Paren Open) ps in
|
|
let (fname, fnsp, ps) = match ps.lt () with
|
|
| Seq.Cons ((TString fname, s), lt) -> (fname, s, { ps with lt; offset = loc_span_end s; })
|
|
| Seq.Cons ((_, s), _) -> Yanais_syntax_err (EExpected XString, s) |> raise
|
|
| Seq.Nil -> Yanais_syntax_err (EUnexpectedEof XString, s1) |> raise
|
|
in
|
|
let (s2, ps) = require_token XLambda (Paren Close) ps in
|
|
let span_end = loc_span_end s2 in
|
|
let fname = match Asai.Range.source s1 with
|
|
| `File forig -> (Filename.dirname forig) ^ "/" ^ fname
|
|
| `String _ -> fname
|
|
in
|
|
let subsource = `File fname in
|
|
let subrunner sublt =
|
|
let subparser = parser_init subsource sublt in
|
|
let (xp, subparser) = parse_expr subparser in
|
|
let ps = { ps with lt; offset = span_end; } in
|
|
match subparser.lt () with
|
|
| Seq.Nil -> (xp, ps)
|
|
| Seq.Cons ((_, posc), _) -> Yanais_syntax_err (EExpected XEof, posc) |> raise
|
|
in try Lex.run subsource subrunner with
|
|
Sys_error e -> Yanais_syntax_err (ESys e, fnsp) |> raise
|
|
)
|
|
| _ -> parse_minexpr ps
|