ocaml/syntax: split code into more modules
This commit is contained in:
parent
5152f2bde0
commit
d4fddeb596
41
ocaml/libsyntax/pattern.ml
Normal file
41
ocaml/libsyntax/pattern.ml
Normal file
|
@ -0,0 +1,41 @@
|
||||||
|
open Tys
|
||||||
|
|
||||||
|
type t =
|
||||||
|
| PatIgnore of loc_span_full
|
||||||
|
| PatName of tagged_ident
|
||||||
|
| PatRecord of t Record.t
|
||||||
|
|
||||||
|
module FieldsReg = Map.Make(String)
|
||||||
|
|
||||||
|
let rec exports stk p = match p with
|
||||||
|
| PatIgnore _ -> stk
|
||||||
|
| PatName tgi -> tgi::stk
|
||||||
|
| PatRecord rcd -> List.fold_left (fun stk (_, _, p) -> exports stk p) stk rcd
|
||||||
|
|
||||||
|
let parse_opt ps =
|
||||||
|
let rec inner ps = match ps.lt with
|
||||||
|
| (PatOut "", s)::lt ->
|
||||||
|
Some (PatIgnore (ps.file, s), { ps with lt; offset = loc_span_end s; })
|
||||||
|
| (PatOut name, s)::lt ->
|
||||||
|
Some (PatName {ident = name; file = ps.file; span = s; }, { ps with lt; offset = loc_span_end s; })
|
||||||
|
| (Brace Open, _)::_ ->
|
||||||
|
let rqp_pattern = require XPattern inner in
|
||||||
|
Some (Record.parse rqp_pattern ps |> (fun (x, ps) -> (PatRecord x, ps)))
|
||||||
|
| _ -> None
|
||||||
|
in let rec chk4dups stk reg = match stk with
|
||||||
|
| [] -> None
|
||||||
|
| x::xs ->
|
||||||
|
match FieldsReg.find_opt x.ident reg with
|
||||||
|
| None -> chk4dups xs (FieldsReg.add x.ident x reg)
|
||||||
|
(* this retrieves the later entry because we iterate the list in reverse *)
|
||||||
|
| Some orig -> Some orig
|
||||||
|
in match inner ps with
|
||||||
|
| None -> None
|
||||||
|
| Some (ret, ps) ->
|
||||||
|
(* check for duplicates *)
|
||||||
|
let ptexports = exports [] ret in
|
||||||
|
match chk4dups ptexports FieldsReg.empty with
|
||||||
|
| None -> Some (ret, ps)
|
||||||
|
| Some { ident; file; span; } -> Yanais_syntax_err (EPatternDupIdent ident, file, span) |> raise
|
||||||
|
|
||||||
|
let parse ps = require XPattern parse_opt ps
|
47
ocaml/libsyntax/record.ml
Normal file
47
ocaml/libsyntax/record.ml
Normal file
|
@ -0,0 +1,47 @@
|
||||||
|
open Tys
|
||||||
|
|
||||||
|
type 'a t = (loc_span_full * (string option) * 'a) list
|
||||||
|
|
||||||
|
module FieldsReg = Set.Make(String)
|
||||||
|
|
||||||
|
let parse_opt (type a) parse_inner = when_got (Brace Open) (fun (_, ps) ->
|
||||||
|
(* note: argument accu is reversed *)
|
||||||
|
let rec inner (accu: a t) (reg: FieldsReg.t) (ps: parser_env) =
|
||||||
|
let unexp_eof ps = (
|
||||||
|
let sp = { start = ps.offset; length = zero_len } in
|
||||||
|
Yanais_syntax_err (EUnexpectedEof XRecord, ps.file, sp) |> raise
|
||||||
|
) in
|
||||||
|
|
||||||
|
(* after we maybe got a name *)
|
||||||
|
let rest ps start mbname =
|
||||||
|
let (xp, ps) = parse_inner ps in
|
||||||
|
let full_sp = loc_span_of_start_end start ps.offset in
|
||||||
|
match ps.lt with
|
||||||
|
| [] -> unexp_eof ps
|
||||||
|
| (SemiColon, sp) :: lt -> (
|
||||||
|
(* continue *)
|
||||||
|
let reg = match mbname with
|
||||||
|
| Some i -> FieldsReg.add i reg
|
||||||
|
| None -> reg
|
||||||
|
in
|
||||||
|
inner (((ps.file, full_sp), mbname, xp)::accu) reg
|
||||||
|
{ ps with lt; offset = loc_span_end sp; }
|
||||||
|
)
|
||||||
|
| (_, sp) :: _ -> Yanais_syntax_err (EExpected XSemiColon, ps.file, sp) |> raise
|
||||||
|
in
|
||||||
|
|
||||||
|
(* recognize a name *)
|
||||||
|
match ps.lt with
|
||||||
|
| (Brace Close, s) :: lt -> (List.rev accu, { ps with lt; offset = loc_span_end s; })
|
||||||
|
| (DotIdent i, s) :: (Assign, _) :: lt -> (
|
||||||
|
if FieldsReg.find_opt i reg |> Option.is_some then (
|
||||||
|
Yanais_syntax_err (ERecordDupIdent i, ps.file, s) |> raise
|
||||||
|
) else
|
||||||
|
let ps = { ps with lt; offset = loc_span_end s; } in
|
||||||
|
rest ps s.start (Some i)
|
||||||
|
)
|
||||||
|
| [] -> unexp_eof ps
|
||||||
|
| _ -> rest ps ps.offset None
|
||||||
|
in inner [] FieldsReg.empty ps)
|
||||||
|
|
||||||
|
let parse parse_inner = require XRecord (parse_opt parse_inner)
|
|
@ -4,15 +4,9 @@ open Tys
|
||||||
|
|
||||||
type stack_ref = int
|
type stack_ref = int
|
||||||
type sel_ident = loc_span_full * stack_ref
|
type sel_ident = loc_span_full * stack_ref
|
||||||
|
type 'a record = 'a Record.t
|
||||||
|
|
||||||
type pattern =
|
type pattern_mt = Pattern.t * ((loc_span_full * expr) option)
|
||||||
| PatIgnore of loc_span_full
|
|
||||||
| PatName of tagged_ident
|
|
||||||
| PatRecord of pattern record
|
|
||||||
|
|
||||||
and pattern_mt = pattern * ((loc_span_full * expr) option)
|
|
||||||
|
|
||||||
and 'a record = (loc_span_full * (string option) * 'a) list
|
|
||||||
|
|
||||||
and lambda =
|
and lambda =
|
||||||
{ pat : pattern_mt
|
{ pat : pattern_mt
|
||||||
|
@ -34,129 +28,9 @@ and expr =
|
||||||
|
|
||||||
(* parser *)
|
(* parser *)
|
||||||
|
|
||||||
type parser_env =
|
|
||||||
{ lt : token_ann list
|
|
||||||
; file : string
|
|
||||||
; offset : int
|
|
||||||
; names : string list
|
|
||||||
}
|
|
||||||
|
|
||||||
let zero_len = Unsigned.UInt32.zero
|
|
||||||
|
|
||||||
let parser_init file lt = { lt; file; offset = 0; names = [] }
|
|
||||||
|
|
||||||
let parse_one ps =
|
|
||||||
match ps.lt with
|
|
||||||
| [] -> None
|
|
||||||
| (k, s) :: xs -> Some (k, s, { ps with lt = xs; offset = loc_span_end s; })
|
|
||||||
|
|
||||||
let got tok ps =
|
|
||||||
match parse_one ps with
|
|
||||||
| Some (k, s, ps) when k == tok -> Some (s, ps)
|
|
||||||
| _ -> None
|
|
||||||
|
|
||||||
let when_got tok thn ps = Option.map thn (got tok ps)
|
|
||||||
|
|
||||||
let next_in_noeof ps (ctx : error_ctx) =
|
|
||||||
match parse_one ps with
|
|
||||||
| Some (k, s, ps) -> (k, s, ps)
|
|
||||||
| None ->
|
|
||||||
let sp = { start = ps.offset; length = zero_len } in
|
|
||||||
Yanais_syntax_err (EUnexpectedEof ctx, ps.file, sp) |> raise
|
|
||||||
|
|
||||||
(* make an optional parser required *)
|
|
||||||
let require ctx parse_inner ps = match parse_inner ps with
|
|
||||||
| Some x -> x
|
|
||||||
| None ->
|
|
||||||
let sp = match ps.lt with
|
|
||||||
| (_, sp)::_ -> sp
|
|
||||||
| [] -> { start = ps.offset; length = zero_len }
|
|
||||||
in Yanais_syntax_err (EExpected ctx, ps.file, sp) |> raise
|
|
||||||
|
|
||||||
let env_lookup_opt name ps =
|
|
||||||
let rec inner names count = match names with
|
|
||||||
| [] -> None
|
|
||||||
| x::xs -> if x == name then Some count else inner xs (count + 1)
|
|
||||||
in inner ps.names 0
|
|
||||||
|
|
||||||
let env_lookup name span ps = match env_lookup_opt name ps with
|
|
||||||
| None -> Yanais_syntax_err (EUnknownIdent name, ps.file, span) |> raise
|
|
||||||
| Some y -> y
|
|
||||||
|
|
||||||
module FieldsReg = Set.Make(String)
|
module FieldsReg = Set.Make(String)
|
||||||
module FieldsReg2 = Map.Make(String)
|
module FieldsReg2 = Map.Make(String)
|
||||||
|
|
||||||
let parse_record (type a) parse_inner = when_got (Brace Open) (fun (_, ps) ->
|
|
||||||
(* note: argument accu is reversed *)
|
|
||||||
let rec inner (accu: a record) (reg: FieldsReg.t) (ps: parser_env) =
|
|
||||||
let unexp_eof ps = (
|
|
||||||
let sp = { start = ps.offset; length = zero_len } in
|
|
||||||
Yanais_syntax_err (EUnexpectedEof XRecord, ps.file, sp) |> raise
|
|
||||||
) in
|
|
||||||
|
|
||||||
(* after we maybe got a name *)
|
|
||||||
let rest ps start mbname =
|
|
||||||
let (xp, ps) = parse_inner ps in
|
|
||||||
let full_sp = loc_span_of_start_end start ps.offset in
|
|
||||||
match ps.lt with
|
|
||||||
| [] -> unexp_eof ps
|
|
||||||
| (SemiColon, sp) :: lt -> (
|
|
||||||
(* continue *)
|
|
||||||
let reg = match mbname with
|
|
||||||
| Some i -> FieldsReg.add i reg
|
|
||||||
| None -> reg
|
|
||||||
in
|
|
||||||
inner (((ps.file, full_sp), mbname, xp)::accu) reg
|
|
||||||
{ ps with lt; offset = loc_span_end sp; }
|
|
||||||
)
|
|
||||||
| (_, sp) :: _ -> Yanais_syntax_err (EExpected XSemiColon, ps.file, sp) |> raise
|
|
||||||
in
|
|
||||||
|
|
||||||
(* recognize a name *)
|
|
||||||
match ps.lt with
|
|
||||||
| (Brace Close, s) :: lt -> (List.rev accu, { ps with lt; offset = loc_span_end s; })
|
|
||||||
| (DotIdent i, s) :: (Assign, _) :: lt -> (
|
|
||||||
if FieldsReg.find_opt i reg |> Option.is_some then (
|
|
||||||
Yanais_syntax_err (ERecordDupIdent i, ps.file, s) |> raise
|
|
||||||
) else
|
|
||||||
let ps = { ps with lt; offset = loc_span_end s; } in
|
|
||||||
rest ps s.start (Some i)
|
|
||||||
)
|
|
||||||
| [] -> unexp_eof ps
|
|
||||||
| _ -> rest ps ps.offset None
|
|
||||||
in inner [] FieldsReg.empty ps)
|
|
||||||
|
|
||||||
let rec pattern_exports stk p = match p with
|
|
||||||
| PatIgnore _ -> stk
|
|
||||||
| PatName tgi -> tgi::stk
|
|
||||||
| PatRecord rcd -> List.fold_left (fun stk (_, _, p) -> pattern_exports stk p) stk rcd
|
|
||||||
|
|
||||||
let parse_pattern ps =
|
|
||||||
let rec inner ps = match ps.lt with
|
|
||||||
| (PatOut "", s)::lt ->
|
|
||||||
Some (PatIgnore (ps.file, s), { ps with lt; offset = loc_span_end s; })
|
|
||||||
| (PatOut name, s)::lt ->
|
|
||||||
Some (PatName {ident = name; file = ps.file; span = s; }, { ps with lt; offset = loc_span_end s; })
|
|
||||||
| (Brace Open, _)::_ ->
|
|
||||||
let rqp_pattern = require XPattern inner in
|
|
||||||
Some (require XRecord (parse_record rqp_pattern) ps |> (fun (x, ps) -> (PatRecord x, ps)))
|
|
||||||
| _ -> None
|
|
||||||
in let rec chk4dups stk reg = match stk with
|
|
||||||
| [] -> None
|
|
||||||
| x::xs ->
|
|
||||||
match FieldsReg2.find_opt x.ident reg with
|
|
||||||
| None -> chk4dups xs (FieldsReg2.add x.ident x reg)
|
|
||||||
(* this retrieves the later entry because we iterate the list in reverse *)
|
|
||||||
| Some orig -> Some orig
|
|
||||||
in match inner ps with
|
|
||||||
| None -> None
|
|
||||||
| Some (ret, ps) ->
|
|
||||||
(* check for duplicates *)
|
|
||||||
let ptexports = pattern_exports [] ret in
|
|
||||||
match chk4dups ptexports FieldsReg2.empty with
|
|
||||||
| None -> Some (ret, ps)
|
|
||||||
| Some { ident; file; span; } -> Yanais_syntax_err (EPatternDupIdent ident, file, span) |> raise
|
|
||||||
|
|
||||||
(* a minimal expression are all parts which are "self contained" enough (e.g. not an apply) *)
|
(* a minimal expression are all parts which are "self contained" enough (e.g. not an apply) *)
|
||||||
let rec parse_minexpr ps =
|
let rec parse_minexpr ps =
|
||||||
let (k, s, ps) = next_in_noeof ps XExpression in
|
let (k, s, ps) = next_in_noeof ps XExpression in
|
||||||
|
@ -176,7 +50,7 @@ let rec parse_minexpr ps =
|
||||||
)
|
)
|
||||||
(*
|
(*
|
||||||
| Lambda -> (
|
| Lambda -> (
|
||||||
let (pat, ps) = require XPattern parse_pattern ps in
|
let (pat, ps) = Pattern.parse in
|
||||||
let (pty, ps) = match parse_ty_annot ps with
|
let (pty, ps) = match parse_ty_annot ps with
|
||||||
| None -> (None, ps)
|
| None -> (None, ps)
|
||||||
| Some (s, ptyx, ps) -> (Some (s, ptyx), ps)
|
| Some (s, ptyx, ps) -> (Some (s, ptyx), ps)
|
||||||
|
|
|
@ -119,3 +119,52 @@ type error_kind =
|
||||||
type error = error_kind * string * loc_span
|
type error = error_kind * string * loc_span
|
||||||
|
|
||||||
exception Yanais_syntax_err of error
|
exception Yanais_syntax_err of error
|
||||||
|
|
||||||
|
type parser_env =
|
||||||
|
{ lt : token_ann list
|
||||||
|
; file : string
|
||||||
|
; offset : int
|
||||||
|
; names : string list
|
||||||
|
}
|
||||||
|
|
||||||
|
let zero_len = Unsigned.UInt32.zero
|
||||||
|
|
||||||
|
let parser_init file lt = { lt; file; offset = 0; names = [] }
|
||||||
|
|
||||||
|
let parse_one ps =
|
||||||
|
match ps.lt with
|
||||||
|
| [] -> None
|
||||||
|
| (k, s) :: xs -> Some (k, s, { ps with lt = xs; offset = loc_span_end s; })
|
||||||
|
|
||||||
|
let got tok ps =
|
||||||
|
match parse_one ps with
|
||||||
|
| Some (k, s, ps) when k == tok -> Some (s, ps)
|
||||||
|
| _ -> None
|
||||||
|
|
||||||
|
let when_got tok thn ps = Option.map thn (got tok ps)
|
||||||
|
|
||||||
|
let next_in_noeof ps (ctx : error_ctx) =
|
||||||
|
match parse_one ps with
|
||||||
|
| Some (k, s, ps) -> (k, s, ps)
|
||||||
|
| None ->
|
||||||
|
let sp = { start = ps.offset; length = zero_len } in
|
||||||
|
Yanais_syntax_err (EUnexpectedEof ctx, ps.file, sp) |> raise
|
||||||
|
|
||||||
|
(* make an optional parser required *)
|
||||||
|
let require ctx parse_inner ps = match parse_inner ps with
|
||||||
|
| Some x -> x
|
||||||
|
| None ->
|
||||||
|
let sp = match ps.lt with
|
||||||
|
| (_, sp)::_ -> sp
|
||||||
|
| [] -> { start = ps.offset; length = zero_len }
|
||||||
|
in Yanais_syntax_err (EExpected ctx, ps.file, sp) |> raise
|
||||||
|
|
||||||
|
let env_lookup_opt name ps =
|
||||||
|
let rec inner names count = match names with
|
||||||
|
| [] -> None
|
||||||
|
| x::xs -> if x == name then Some count else inner xs (count + 1)
|
||||||
|
in inner ps.names 0
|
||||||
|
|
||||||
|
let env_lookup name span ps = match env_lookup_opt name ps with
|
||||||
|
| None -> Yanais_syntax_err (EUnknownIdent name, ps.file, span) |> raise
|
||||||
|
| Some y -> y
|
||||||
|
|
Loading…
Reference in a new issue