diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/parse_ast.ml | 1 | ||||
| -rw-r--r-- | src/parser.mly | 2 | ||||
| -rw-r--r-- | src/process_file.ml | 44 | ||||
| -rw-r--r-- | src/rewrites.mli | 3 | ||||
| -rw-r--r-- | src/type_check.ml | 1 |
5 files changed, 51 insertions, 0 deletions
diff --git a/src/parse_ast.ml b/src/parse_ast.ml index 826d8eb1..635caa9c 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -363,6 +363,7 @@ funcl_aux = (* Function clause *) type type_union_aux = (* Type union constructors *) Tu_ty_id of atyp * id + | Tu_ty_anon_rec of (atyp * id) list * id type diff --git a/src/parser.mly b/src/parser.mly index 0846d4bb..c0559719 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -1168,6 +1168,8 @@ type_union: { Tu_aux (Tu_ty_id ($3, $1), loc $startpos $endpos) } | id Colon typ MinusGt typ { (fun s e -> Tu_aux (Tu_ty_id (mk_typ (ATyp_fn ($3, $5, mk_typ (ATyp_set []) s e)) s e, $1), loc s e)) $startpos $endpos } + | id Colon Lcurly struct_fields Rcurly + { Tu_aux (Tu_ty_anon_rec ($4, $1), loc $startpos $endpos) } type_unions: | type_union diff --git a/src/process_file.ml b/src/process_file.ml index a576c16e..681d7c68 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -112,6 +112,36 @@ let cond_pragma defs = in scan defs +let astid_to_string (Ast.Id_aux (id, _)) = + match id with + | Ast.Id x | Ast.DeIid x -> x + +let parseid_to_string (Parse_ast.Id_aux (id, _)) = + match id with + | Parse_ast.Id x | Parse_ast.DeIid x -> x + +let rec realise_union_anon_rec_types (Parse_ast.TD_variant (union_id, name_scm_opt, typq, _, flag) as orig_union) arms = + match arms with + | [] -> [] + | arm :: arms -> + match arm with + | (Parse_ast.Tu_aux ((Parse_ast.Tu_ty_id _), _)) -> (None, arm) :: realise_union_anon_rec_types orig_union arms + | (Parse_ast.Tu_aux ((Parse_ast.Tu_ty_anon_rec (fields, id)), l)) -> + let open Parse_ast in + let ast_record_id = Rewrites.fresh_id ("__anon_rec_" ^ parseid_to_string union_id ^ "_") (Parse_ast.Generated l) in + let record_str = astid_to_string ast_record_id in + let record_id = Id_aux (Id record_str, Generated l) in + let new_arm = Parse_ast.Tu_aux + ((Parse_ast.Tu_ty_id ( + (Parse_ast.ATyp_aux (ATyp_id record_id, Generated l)), + id) + ), Parse_ast.Generated l) in + let new_rec_def = Parse_ast.DEF_type (Parse_ast.TD_aux ( + Parse_ast.TD_record (record_id, name_scm_opt, typq, fields, flag), + Generated l + )) in + (Some new_rec_def, new_arm) :: (realise_union_anon_rec_types orig_union arms) + let rec preprocess = function | [] -> [] | Parse_ast.DEF_pragma ("define", symbol, _) :: defs -> @@ -167,6 +197,20 @@ let rec preprocess = function | Parse_ast.DEF_pragma (p, arg, _) :: defs -> (Util.warn ("Bad pragma $" ^ p ^ " " ^ arg); preprocess defs) + (* realise any anonymous record arms of variants *) + | Parse_ast.DEF_type (Parse_ast.TD_aux + (Parse_ast.TD_variant (id, name_scm_opt, typq, arms, flag) as union, l) + ) :: defs -> + let records_and_arms = realise_union_anon_rec_types union arms in + let rec filter_records = function [] -> [] + | Some x :: xs -> x :: filter_records xs + | None :: xs -> filter_records xs + in + let generated_records = filter_records (List.map fst records_and_arms) in + let rewritten_arms = List.map snd records_and_arms in + let rewritten_union = Parse_ast.TD_variant (id, name_scm_opt, typq, rewritten_arms, flag) in + generated_records @ (Parse_ast.DEF_type (Parse_ast.TD_aux (rewritten_union, l))) :: preprocess defs + | (Parse_ast.DEF_default (Parse_ast.DT_aux (Parse_ast.DT_order (_, Parse_ast.ATyp_aux (atyp, _)), _)) as def) :: defs -> begin match atyp with | Parse_ast.ATyp_inc -> symbols := StringSet.add "_DEFAULT_INC" !symbols; def :: preprocess defs diff --git a/src/rewrites.mli b/src/rewrites.mli index 41a13ffa..70cb75af 100644 --- a/src/rewrites.mli +++ b/src/rewrites.mli @@ -51,6 +51,9 @@ open Ast open Type_check +(* Generate a fresh id with the given prefix *) +val fresh_id : string -> l -> id + (* Re-write undefined to functions created by -undefined_gen flag *) val rewrite_undefined : bool -> tannot defs -> tannot defs diff --git a/src/type_check.ml b/src/type_check.ml index 5c72983a..cd44fd58 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -3675,6 +3675,7 @@ let check_type_union env variant typq (Tu_aux (tu, l)) = env |> Env.add_union_id v (typq, typ') |> Env.add_val_spec v (typq, typ') + | Tu_ty_anon_rec _ -> typ_error l "Unrewritten Tu_ty_anon_rec seen by typechecker" (* FIXME: This code is duplicated with general kind-checking code in environment, can they be merged? *) let mk_synonym typq typ = |