ocaml/syntax: split code into more modules
This commit is contained in:
Alain Zscheile
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 sel_ident = loc_span_full * stack_ref
|
||||
type 'a record = 'a Record.t
|
||||
|
||||
type pattern =
|
||||
| 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
|
||||
type pattern_mt = Pattern.t * ((loc_span_full * expr) option)
|
||||
|
||||
and lambda =
|
||||
{ pat : pattern_mt
|
||||
|
|
@ -34,129 +28,9 @@ and expr =
|
|||
|
||||
(* 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 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) *)
|
||||
let rec parse_minexpr ps =
|
||||
let (k, s, ps) = next_in_noeof ps XExpression in
|
||||
|
|
@ -176,7 +50,7 @@ let rec parse_minexpr ps =
|
|||
)
|
||||
(*
|
||||
| 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
|
||||
| None -> (None, ps)
|
||||
| Some (s, ptyx, ps) -> (Some (s, ptyx), ps)
|
||||
|
|
|
|||
|
|
@ -119,3 +119,52 @@ type error_kind =
|
|||
type error = error_kind * string * loc_span
|
||||
|
||||
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