diff --git a/.vscode/settings.json b/.vscode/settings.json new file mode 100644 index 00000000000..fed0bcc5c1c --- /dev/null +++ b/.vscode/settings.json @@ -0,0 +1,5 @@ +{ + "files.associations": { + "*.tiny": "fstar" + } +} \ No newline at end of file diff --git a/src/basic/FStarC.Options.fst b/src/basic/FStarC.Options.fst index 6874ce898d8..044ef2c8d98 100644 --- a/src/basic/FStarC.Options.fst +++ b/src/basic/FStarC.Options.fst @@ -235,6 +235,7 @@ let defaults = [ ("initial_ifuel" , Int 1); ("keep_query_captions" , Bool true); ("krmloutput" , Unset); + ("lang_extensions" , List []); ("lax" , Bool false); ("list_plugins" , Bool false); ("load_cmxs" , List []); @@ -502,6 +503,7 @@ let get_print_in_place () = lookup_opt "print_in_place" let get_initial_fuel () = lookup_opt "initial_fuel" as_int let get_initial_ifuel () = lookup_opt "initial_ifuel" as_int let get_keep_query_captions () = lookup_opt "keep_query_captions" as_bool +let get_lang_extensions () = lookup_opt "lang_extensions" (as_list as_string) let get_lax () = lookup_opt "lax" as_bool let get_load () = lookup_opt "load" (as_list as_string) let get_load_cmxs () = lookup_opt "load_cmxs" (as_list as_string) @@ -1124,6 +1126,11 @@ let specs_with_types warn_unsafe : list (char & string & opt_type & Pprint.docum BoolStr, text "Retain comments in the logged SMT queries (requires --log_queries or --log_failing_queries; default true)"); + ( noshort, + "lang_extensions", + Accumulated (SimpleStr "extension"), + text "Automatically enable the given language extensions based on the file extension; the language extension's .cmxs must be on the include path or loaded with --load_cmxs"); + ( noshort, "lax", WithSideEffect ((fun () -> if warn_unsafe then option_warning_callback "lax"), Const (Bool true)), @@ -1769,6 +1776,7 @@ let settable = function | "initial_ifuel" | "ide_id_info_off" | "keep_query_captions" + | "lang_extensions" | "load" | "load_cmxs" | "log_queries" @@ -2126,6 +2134,7 @@ let print () = get_print () let print_in_place () = get_print_in_place () let initial_fuel () = min (get_initial_fuel ()) (get_max_fuel ()) let initial_ifuel () = min (get_initial_ifuel ()) (get_max_ifuel ()) +let lang_extensions () = get_lang_extensions () let lax () = get_lax () let load () = get_load () let load_cmxs () = get_load_cmxs () diff --git a/src/basic/FStarC.Options.fsti b/src/basic/FStarC.Options.fsti index 4d7ddc8eb84..5c4c20dba77 100644 --- a/src/basic/FStarC.Options.fsti +++ b/src/basic/FStarC.Options.fsti @@ -162,6 +162,7 @@ val initial_fuel : unit -> int val initial_ifuel : unit -> int val interactive : unit -> bool val keep_query_captions : unit -> bool +val lang_extensions : unit -> list string val lax : unit -> bool val load : unit -> list string val load_cmxs : unit -> list string diff --git a/src/ml/FStarC_Parser_ParseIt.ml b/src/ml/FStarC_Parser_ParseIt.ml index 1cee2a5ea55..ad7f8fe3102 100644 --- a/src/ml/FStarC_Parser_ParseIt.ml +++ b/src/ml/FStarC_Parser_ParseIt.ml @@ -76,14 +76,19 @@ let read_file (filename:string) = if debug then FStarC_Format.print1 "Opening file %s\n" filename; filename, read_physical_file filename -let fst_extensions = [".fst"; ".fsti"] -let interface_extensions = [".fsti"] +let extra_extensions () = List.concat_map (fun x -> ["." ^ x; "." ^ x ^ "i"]) (FStarC_Options.lang_extensions ()) +let fst_extensions () = [".fst"; ".fsti"] @ extra_extensions () +let extra_extensions_interface () = List.map (fun x -> "." ^ x ^ "i") (FStarC_Options.lang_extensions ()) +let interface_extensions () = [".fsti"] @ extra_extensions_interface () let has_extension file extensions = FStar_List.existsb (U.ends_with file) extensions +let take_lang_extension file = + FStar_List.tryFind (fun x -> U.ends_with file ("."^x)) (FStarC_Options.lang_extensions ()) + let check_extension fn = - if (not (has_extension fn fst_extensions)) then + if (not (has_extension fn (fst_extensions ()))) then let message = FStarC_Format.fmt1 "Unrecognized extension '%s'" fn in raise_error_text FStarC_Range.dummyRange Fatal_UnrecognizedExtension message @@ -521,91 +526,129 @@ let _ = FStarC_Parser_AST_Util.register_extension_lang_parser "fstar" parse_fsta type lang_opts = string option let parse_lang lang fn = - match fn with - | Filename _ -> - failwith "parse_lang: only in incremental mode" - | Incremental s - | Toplevel s - | Fragment s -> - try - let frag_pos = FStarC_Range.mk_pos s.frag_line s.frag_col in - let rng = FStarC_Range.mk_range s.frag_fname frag_pos frag_pos in - let decls = FStarC_Parser_AST_Util.parse_extension_lang lang s.frag_text rng in - let comments = FStarC_Parser_Util.flush_comments () in - ASTFragment (Inr decls, comments) - with + let frag = + match fn with + | Filename f -> + check_extension f; + let f', contents = read_file f in + { + frag_fname = f'; + frag_text = contents; + frag_line = Z.one; + frag_col = Z.zero; + } + | Incremental frag + | Toplevel frag + | Fragment frag -> frag + in + try + let frag_pos = FStarC_Range.mk_pos frag.frag_line frag.frag_col in + let rng = FStarC_Range.mk_range frag.frag_fname frag_pos frag_pos in + let contents_at = contents_at frag.frag_text in + let decls = FStarC_Parser_AST_Util.parse_extension_lang lang frag.frag_text rng in + let comments = FStarC_Parser_Util.flush_comments () in + match fn with + | Filename _ | Toplevel _ -> + ASTFragment (FStarC_Parser_AST.as_frag decls, comments) + | Incremental _ -> + let decls = List.map (fun d -> d, contents_at d.FStarC_Parser_AST.drange) decls in + IncrementalFragment (decls, comments, None) + | Fragment _ -> + (* parse_no_lang returns `Term` for Fragment, but we don't have a term parser for language extensions *) + ASTFragment (FStar_Pervasives.Inr decls, comments) + with + | FStarC_Errors.Error(e, msg, r, _ctx) -> + ParseError (e, msg, r) + +let parse_no_lang fn = + let lexbuf, filename, contents = + match fn with + | Filename f -> + check_extension f; + let f', contents = read_file f in + (try create contents f' 1 0, f', contents + with _ -> raise_error_text FStarC_Range.dummyRange Fatal_InvalidUTF8Encoding (FStarC_Format.fmt1 "File %s has invalid UTF-8 encoding." f')) + | Incremental s + | Toplevel s + | Fragment s -> + create s.frag_text s.frag_fname (Z.to_int s.frag_line) (Z.to_int s.frag_col), "", s.frag_text + in + + let lexer () = + let tok = FStarC_Parser_LexFStar.token lexbuf in + if !dbg_Tokens then + print_string ("TOKEN: " ^ (string_of_token tok) ^ "\n"); + (tok, lexbuf.start_p, lexbuf.cur_p) + in + try + match fn with + | Filename _ + | Toplevel _ -> begin + let fileOrFragment = + MenhirLib.Convert.Simplified.traditional2revised FStarC_Parser_Parse.inputFragment lexer + in + let frags = match fileOrFragment with + | FStar_Pervasives.Inl modul -> + if has_extension filename (interface_extensions ()) + then FStar_Pervasives.Inl (FStarC_Parser_AST.as_interface modul) + else FStar_Pervasives.Inl modul + | _ -> fileOrFragment + in ASTFragment (frags, FStarC_Parser_Util.flush_comments ()) + end + + | Incremental i -> + let decls, comments, err_opt = + parse_incremental_fragment + filename + i.frag_text + lexbuf + lexer + (fun (d:FStarC_Parser_AST.decl) -> d.drange) + FStarC_Parser_Parse.oneDeclOrEOF + in + IncrementalFragment(decls, comments, err_opt) + + | Fragment _ -> + Term (MenhirLib.Convert.Simplified.traditional2revised FStarC_Parser_Parse.term lexer) + with + | FStarC_Errors.Empty_frag -> + ASTFragment (FStar_Pervasives.Inr [], []) + | FStarC_Errors.Error(e, msg, r, _ctx) -> ParseError (e, msg, r) + | e -> +(* + | Parsing.Parse_error as _e + | FStarC_Parser_Parse.MenhirBasics.Error as _e -> +*) + ParseError (err_of_parse_error filename lexbuf None) + + let parse (lang_opt:lang_opts) fn = FStarC_Stats.record "parse" @@ fun () -> FStarC_Parser_Util.warningHandler := (function | e -> Printf.printf "There was some warning (TODO)\n"); + match lang_opt with | Some lang -> parse_lang lang fn - | _ -> - let lexbuf, filename, contents = - match fn with - | Filename f -> - check_extension f; - let f', contents = read_file f in - (try create contents f' 1 0, f', contents - with _ -> raise_error_text FStarC_Range.dummyRange Fatal_InvalidUTF8Encoding (FStarC_Format.fmt1 "File %s has invalid UTF-8 encoding." f')) - | Incremental s - | Toplevel s - | Fragment s -> - create s.frag_text s.frag_fname (Z.to_int s.frag_line) (Z.to_int s.frag_col), "", s.frag_text + | None -> + let filename = + match fn with + | Filename fn -> fn + | Toplevel frag -> frag.frag_fname + | Incremental frag -> frag.frag_fname + | Fragment frag -> frag.frag_fname in - - let lexer () = - let tok = FStarC_Parser_LexFStar.token lexbuf in - if !dbg_Tokens then - print_string ("TOKEN: " ^ (string_of_token tok) ^ "\n"); - (tok, lexbuf.start_p, lexbuf.cur_p) + let filename = + (* If in IDE mode, the IDE filename takes precedence as frag_fname might be "" *) + if FStarC_Options.ide () && filename = "" + then Option.value ~default:filename (FStarC_Options.ide_filename ()) + else filename in - try - match fn with - | Filename _ - | Toplevel _ -> begin - let fileOrFragment = - MenhirLib.Convert.Simplified.traditional2revised FStarC_Parser_Parse.inputFragment lexer - in - let frags = match fileOrFragment with - | FStar_Pervasives.Inl modul -> - if has_extension filename interface_extensions - then FStar_Pervasives.Inl (FStarC_Parser_AST.as_interface modul) - else FStar_Pervasives.Inl modul - | _ -> fileOrFragment - in ASTFragment (frags, FStarC_Parser_Util.flush_comments ()) - end - - | Incremental i -> - let decls, comments, err_opt = - parse_incremental_fragment - filename - i.frag_text - lexbuf - lexer - (fun (d:FStarC_Parser_AST.decl) -> d.drange) - FStarC_Parser_Parse.oneDeclOrEOF - in - IncrementalFragment(decls, comments, err_opt) - - | Fragment _ -> - Term (MenhirLib.Convert.Simplified.traditional2revised FStarC_Parser_Parse.term lexer) - with - | FStarC_Errors.Empty_frag -> - ASTFragment (FStar_Pervasives.Inr [], []) - - | FStarC_Errors.Error(e, msg, r, _ctx) -> - ParseError (e, msg, r) - - | e -> - (* - | Parsing.Parse_error as _e - | FStarC_Parser_Parse.MenhirBasics.Error as _e -> - *) - ParseError (err_of_parse_error filename lexbuf None) + match take_lang_extension filename with + | Some lang -> parse_lang lang fn + | None -> parse_no_lang fn (** Parsing of command-line error/warning/silent flags. *) diff --git a/src/parser/FStarC.Parser.Dep.fst b/src/parser/FStarC.Parser.Dep.fst index f06a9aaa017..be4cef96291 100644 --- a/src/parser/FStarC.Parser.Dep.fst +++ b/src/parser/FStarC.Parser.Dep.fst @@ -87,8 +87,12 @@ let files_for_module_name_to_string (m:files_for_module_name) = type color = | White | Gray | Black +let all_file_suffixes () = + let lang_exts = List.map (fun ext -> "." ^ ext) (FStarC.Options.lang_extensions ()) in + let base = ".fst" :: lang_exts in + base @ List.map (fun ext -> ext ^ "i") base + let check_and_strip_suffix (f: string): option string = - let suffixes = [ ".fsti"; ".fst" ] in let matches = List.map (fun ext -> let lext = String.length ext in let l = String.length f in @@ -96,7 +100,7 @@ let check_and_strip_suffix (f: string): option string = Some (String.substring f 0 (l - lext)) else None - ) suffixes in + ) (all_file_suffixes ()) in match List.filter Some? matches with | Some m :: _ -> Some m @@ -1442,7 +1446,7 @@ let all_files_in_include_paths () = List.collect (fun path -> let files = safe_readdir_for_include path in - let files = List.filter (fun f -> Util.ends_with f ".fst" || Util.ends_with f ".fsti") files in + let files = List.filter (fun f -> List.existsb (fun ext -> Util.ends_with f ext) (all_file_suffixes ())) files in List.map (fun file -> Filepath.join_paths path file) files) paths diff --git a/src/syntax/FStarC.Syntax.DsEnv.fst b/src/syntax/FStarC.Syntax.DsEnv.fst index 28b03629509..de9fd4af538 100644 --- a/src/syntax/FStarC.Syntax.DsEnv.fst +++ b/src/syntax/FStarC.Syntax.DsEnv.fst @@ -1614,7 +1614,6 @@ let inclusion_info env (l:lident) = let prepare_module_or_interface intf admitted env mname (mii:module_inclusion_info) = (* AR: open the pervasives namespace *) let prep env = - let filename = BU.strcat (string_of_lid mname) ".fst" in let auto_open = if mii.mii_no_prelude then [] else FStarC.Parser.Dep.prelude in let auto_open = let convert_kind = function diff --git a/tests/Makefile b/tests/Makefile index b66a73bb59e..f2350f0d07a 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -24,6 +24,8 @@ SUBDIRS_ALL += dune_hello SUBDIRS_CLEAN += dune_hello SUBDIRS_ALL += incl SUBDIRS_CLEAN += incl +SUBDIRS_ALL += extension-lang +SUBDIRS_CLEAN += extension-lang FSTAR_ROOT ?= .. include $(FSTAR_ROOT)/mk/test.mk diff --git a/tests/extension-lang/Makefile b/tests/extension-lang/Makefile new file mode 100644 index 00000000000..f46f433cefb --- /dev/null +++ b/tests/extension-lang/Makefile @@ -0,0 +1,26 @@ +# This is a very simple Makefile to test the language extensions. +# We define a `tiny` language extension and use it with the file extension `.tiny`. +# I avoid using the mk/test.mk here because it doesn't support other file extensions. + +FSTAR_OPT = --load TinyPlugin --lang_extensions tiny --already_cached FStar,Prims --cache_checked_modules --cache_dir .cache +FSTAR_EXE ?= fstar.exe + +SRCS = Test0DotFst.fst Test1DotTiny.tiny Test2DotTiny.tiny +CHECKED = $(patsubst %,%.checked,$(SRCS)) + +all: $(CHECKED) +.PHONY: all + +clean: + rm -rf .cache + rm TinyPlugin.cmi TinyPlugin.cmx TinyPlugin.o TinyPlugin.cmxs + rm -f .depend +.PHONY: clean + +%.checked: % TinyPlugin.cmxs + $(FSTAR_EXE) $(FSTAR_OPT) $< + +.depend: + $(FSTAR_EXE) $(FSTAR_OPT) --dep full $(SRCS) -o .depend + +include .depend diff --git a/tests/extension-lang/Test0DotFst.fst b/tests/extension-lang/Test0DotFst.fst new file mode 100644 index 00000000000..ba9cad655a0 --- /dev/null +++ b/tests/extension-lang/Test0DotFst.fst @@ -0,0 +1,4 @@ +module Test0DotFst +#lang-tiny +let:x:10 +let:y:20 \ No newline at end of file diff --git a/tests/extension-lang/Test1DotTiny.tiny b/tests/extension-lang/Test1DotTiny.tiny new file mode 100644 index 00000000000..3ab31321fca --- /dev/null +++ b/tests/extension-lang/Test1DotTiny.tiny @@ -0,0 +1,2 @@ +module:Test1DotTiny +let:export:1 \ No newline at end of file diff --git a/tests/extension-lang/Test2DotTiny.tiny b/tests/extension-lang/Test2DotTiny.tiny new file mode 100644 index 00000000000..924cd256ba7 --- /dev/null +++ b/tests/extension-lang/Test2DotTiny.tiny @@ -0,0 +1,3 @@ +module:Test2DotTiny +let:refer_fst:Test0DotFst.x +let:refer_tiny:Test1DotTiny.export \ No newline at end of file diff --git a/tests/extension-lang/TinyPlugin.ml b/tests/extension-lang/TinyPlugin.ml new file mode 100644 index 00000000000..9fac23f0127 --- /dev/null +++ b/tests/extension-lang/TinyPlugin.ml @@ -0,0 +1,82 @@ +(* This is a tiny toy language extension for F*. + It's deliberately different from F* syntax -- we want to be able to test top level module declarations. + We want to test inter-module dependencies, so we have a simple expression language with qualified identifiers + and integer literals. + + Grammar: + + DECL ::= + | "module:" QID + | "let:" ID ":" EXPR + | "comment:" ... + + EXPR ::= + | QID | INTLIT +*) +(* I wrote this in OCaml to avoid needing to extract ... maybe bad idea *) +open Fstarcompiler +open FStar_Pervasives + +module I = FStarC_Ident +module FPA = FStarC_Parser_AST +module FPAU = FStarC_Parser_AST_Util + +let take_prefix (prefix: string) (s: string) = + if String.starts_with ~prefix s then + Some (String.sub s (String.length prefix) (String.length s - String.length prefix)) + else + None + +let err str r = Inl { FPAU.message = [(*TODO*)]; FPAU.range = r } + +let mk_ident (id_str: string) (r: FStarC_Range.t): I.ident = + I.mk_ident (id_str, r) + +let mk_lident (id_str: string) (r: FStarC_Range.t): I.lident = + I.lid_of_str id_str + +let parse_let (contents: string) (r: FStarC_Range.t): (FPAU.error_message, FPA.decl list) either = + match String.split_on_char ':' contents with + | [id_str; expr_str] -> + let id = mk_ident id_str r in + let tm = match int_of_string_opt expr_str with + | Some int_lit -> FPA.mk_term (FPA.Const (FStarC_Const.Const_int (string_of_int int_lit, None))) r FPA.Expr + | None -> FPA.mk_term (FPA.Var (mk_lident expr_str r)) r FPA.Expr + in + let q = FPA.NoLetQualifier in + let pat = FPA.mk_pattern (FPA.PatVar (id, None, [])) r in + let let_decl = FPA.mk_decl (FPA.TopLevelLet (q, [pat, tm])) r [] in + Inr [let_decl] + | _ -> err "bad let" r + +let parse_line (contents: string) (r: FStarC_Range.t): (FPAU.error_message, FPA.decl list) either = + match take_prefix "module:" contents with + | Some mod_name -> + let lid = mk_lident mod_name r in + Inr [FPA.mk_decl (FPA.TopLevelModule lid) r []] + | None -> + match take_prefix "let:" contents with + | Some rest -> + parse_let rest r + | None -> + match take_prefix "comment:" contents with + | Some _ -> Inr [] + | None -> + if contents = "" then Inr [] + else err "bad decl" r + +let parse_tiny_decls (contents: string) (r: FStarC_Range.t): (FPAU.error_message, FPA.decl list) either = + let rec go acc ls = + match ls with + | [] -> Inr acc + | l::ls -> + match parse_line l r with + | Inl err -> Inl err + | Inr decls -> go (acc @ decls) ls + in + let lines = String.split_on_char '\n' contents in + go [] lines + +let parse_tiny: FPAU.extension_lang_parser = { parse_decls = parse_tiny_decls } + +let () = FStarC_Parser_AST_Util.register_extension_lang_parser "tiny" parse_tiny; diff --git a/tests/extension-lang/extension.fst.config.json b/tests/extension-lang/extension.fst.config.json new file mode 100644 index 00000000000..a9bc39581ea --- /dev/null +++ b/tests/extension-lang/extension.fst.config.json @@ -0,0 +1,3 @@ +{ + "options": [ "--load", "TinyPlugin", "--lang_extensions", "tiny", "--odir", "out", "-o", "out/o" ] +} \ No newline at end of file